summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.fossil-settings/crlf-glob2
-rw-r--r--.fossil-settings/encoding-glob4
-rw-r--r--.github/workflows/linux-build.yml6
-rw-r--r--.github/workflows/mac-build.yml11
-rw-r--r--.github/workflows/onefiledist.yml152
-rw-r--r--.github/workflows/win-build.yml11
-rw-r--r--.project2
-rw-r--r--.travis.yml101
-rw-r--r--ChangeLog.20034
-rw-r--r--ChangeLog.20082
-rw-r--r--README.md14
-rw-r--r--changes263
-rw-r--r--compat/fake-rfc2553.c3
-rw-r--r--compat/float.h14
-rw-r--r--compat/mkstemp.c11
-rw-r--r--compat/opendir.c2
-rw-r--r--compat/stdint.h919
-rw-r--r--compat/string.h8
-rw-r--r--compat/unistd.h76
-rw-r--r--compat/waitpid.c2
-rw-r--r--compat/zlib/win64/libz.dll.abin53518 -> 13480 bytes
-rwxr-xr-xcompat/zlib/win64/zlib1.dllbin134656 -> 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.3206
-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.317
-rw-r--r--doc/DictObj.367
-rw-r--r--doc/DoubleObj.312
-rw-r--r--doc/Encoding.3113
-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.3198
-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.350
-rw-r--r--doc/OpenTcp.320
-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.325
-rw-r--r--doc/Tcl_Main.317
-rw-r--r--doc/Thread.312
-rw-r--r--doc/ToUpper.313
-rw-r--r--doc/TraceVar.339
-rw-r--r--doc/UniCharIsAlpha.310
-rw-r--r--doc/Utf.3110
-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.n371
-rw-r--r--doc/callback.n88
-rw-r--r--doc/catch.n6
-rw-r--r--doc/cd.n6
-rw-r--r--doc/chan.n1133
-rw-r--r--doc/class.n2
-rw-r--r--doc/classvariable.n78
-rw-r--r--doc/clock.n45
-rw-r--r--doc/close.n4
-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.n599
-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.n485
-rw-r--r--doc/fblocked.n4
-rw-r--r--doc/fconfigure.n20
-rw-r--r--doc/fcopy.n5
-rw-r--r--doc/file.n103
-rw-r--r--doc/fileevent.n4
-rw-r--r--doc/filename.n7
-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/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.n649
-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.n9
-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.n92
-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.n145
-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.n4
-rw-r--r--doc/pwd.n4
-rw-r--r--doc/refchan.n13
-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/trace.n3
-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/vwait.n71
-rw-r--r--doc/while.n4
-rw-r--r--doc/zipfs.3120
-rw-r--r--doc/zipfs.n256
-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.h11
-rw-r--r--generic/rege_dfa.c4
-rw-r--r--generic/regerror.c3
-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.decls899
-rw-r--r--generic/tcl.h827
-rw-r--r--generic/tclAlloc.c88
-rwxr-xr-xgeneric/tclArithSeries.c1004
-rw-r--r--generic/tclArithSeries.h58
-rw-r--r--generic/tclAssembly.c138
-rw-r--r--generic/tclAsync.c216
-rw-r--r--generic/tclBasic.c2117
-rw-r--r--generic/tclBinary.c738
-rw-r--r--generic/tclCkalloc.c345
-rw-r--r--generic/tclClock.c176
-rw-r--r--generic/tclCmdAH.c855
-rw-r--r--generic/tclCmdIL.c1596
-rw-r--r--generic/tclCmdMZ.c1300
-rw-r--r--generic/tclCompCmds.c264
-rw-r--r--generic/tclCompCmdsGR.c406
-rw-r--r--generic/tclCompCmdsSZ.c510
-rw-r--r--generic/tclCompExpr.c188
-rw-r--r--generic/tclCompile.c760
-rw-r--r--generic/tclCompile.h289
-rw-r--r--generic/tclConfig.c35
-rw-r--r--generic/tclDate.c6
-rw-r--r--generic/tclDecls.h2127
-rw-r--r--generic/tclDictObj.c606
-rw-r--r--generic/tclDisassemble.c178
-rw-r--r--generic/tclEncoding.c1649
-rw-r--r--generic/tclEnsemble.c620
-rw-r--r--generic/tclEnv.c15
-rw-r--r--generic/tclEvent.c587
-rw-r--r--generic/tclExecute.c2548
-rw-r--r--generic/tclFCmd.c253
-rw-r--r--generic/tclFileName.c134
-rw-r--r--generic/tclFileSystem.h2
-rw-r--r--generic/tclGet.c34
-rw-r--r--generic/tclGetDate.y5
-rw-r--r--generic/tclHash.c190
-rw-r--r--generic/tclHistory.c17
-rw-r--r--generic/tclIO.c1160
-rw-r--r--generic/tclIO.h25
-rw-r--r--generic/tclIOCmd.c305
-rw-r--r--generic/tclIOGT.c107
-rw-r--r--generic/tclIORChan.c415
-rw-r--r--generic/tclIORTrans.c244
-rw-r--r--generic/tclIOSock.c104
-rw-r--r--generic/tclIOUtil.c2338
-rw-r--r--generic/tclIndexObj.c249
-rw-r--r--generic/tclInt.decls517
-rw-r--r--generic/tclInt.h1935
-rw-r--r--generic/tclIntDecls.h436
-rw-r--r--generic/tclIntPlatDecls.h35
-rw-r--r--generic/tclInterp.c286
-rw-r--r--generic/tclLink.c1304
-rw-r--r--generic/tclListObj.c3697
-rw-r--r--generic/tclLiteral.c112
-rw-r--r--generic/tclLoad.c923
-rw-r--r--generic/tclLoadNone.c50
-rw-r--r--generic/tclMain.c66
-rw-r--r--generic/tclNamesp.c406
-rw-r--r--generic/tclNotify.c340
-rw-r--r--generic/tclOO.c683
-rw-r--r--generic/tclOO.decls26
-rw-r--r--generic/tclOO.h38
-rw-r--r--generic/tclOOBasic.c190
-rw-r--r--generic/tclOOCall.c948
-rw-r--r--generic/tclOODecls.h67
-rw-r--r--generic/tclOODefineCmds.c860
-rw-r--r--generic/tclOOInfo.c316
-rw-r--r--generic/tclOOInt.h204
-rw-r--r--generic/tclOOMethod.c258
-rw-r--r--generic/tclOOScript.h263
-rw-r--r--generic/tclOOStubInit.c14
-rw-r--r--generic/tclOOStubLib.c9
-rw-r--r--generic/tclObj.c1556
-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.c759
-rw-r--r--generic/tclPipe.c86
-rw-r--r--generic/tclPkg.c559
-rw-r--r--generic/tclPkgConfig.c17
-rw-r--r--generic/tclPlatDecls.h45
-rw-r--r--generic/tclPort.h15
-rw-r--r--generic/tclPosixStr.c112
-rw-r--r--generic/tclPreserve.c23
-rw-r--r--generic/tclProc.c509
-rw-r--r--generic/tclProcess.c950
-rw-r--r--generic/tclRegexp.c90
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclResolve.c8
-rw-r--r--generic/tclResult.c119
-rw-r--r--generic/tclScan.c77
-rw-r--r--generic/tclStrToD.c940
-rw-r--r--generic/tclStringObj.c2420
-rw-r--r--generic/tclStringRep.h83
-rw-r--r--generic/tclStubInit.c1038
-rw-r--r--generic/tclStubLib.c56
-rw-r--r--generic/tclTest.c2006
-rw-r--r--generic/tclTestObj.c731
-rw-r--r--generic/tclTestProcBodyObj.c28
-rw-r--r--generic/tclThread.c57
-rw-r--r--generic/tclThreadAlloc.c166
-rw-r--r--generic/tclThreadJoin.c6
-rw-r--r--generic/tclThreadStorage.c22
-rw-r--r--generic/tclThreadTest.c101
-rw-r--r--generic/tclTimer.c74
-rw-r--r--generic/tclTomMath.decls166
-rw-r--r--generic/tclTomMath.h1164
-rw-r--r--generic/tclTomMathDecls.h552
-rw-r--r--generic/tclTomMathInterface.c136
-rw-r--r--generic/tclTomMathStubLib.c9
-rw-r--r--generic/tclTrace.c328
-rw-r--r--generic/tclUniData.c2
-rw-r--r--generic/tclUtf.c974
-rw-r--r--generic/tclUtil.c808
-rw-r--r--generic/tclVar.c1563
-rw-r--r--generic/tclZipfs.c6015
-rw-r--r--generic/tclZlib.c240
-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/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/reg/pkgIndex.tcl9
-rw-r--r--library/registry/pkgIndex.tcl9
-rw-r--r--library/safe.tcl415
-rw-r--r--library/tclIndex136
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl57
-rw-r--r--library/tm.tcl6
-rw-r--r--library/word.tcl28
-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.h59
-rw-r--r--libtommath/tommath_private.h32
-rwxr-xr-xlibtommath/win32/libtommath.dllbin0 -> 71680 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 -> 80896 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.pbxproj206
-rw-r--r--macosx/configure.ac2
-rw-r--r--macosx/tclMacOSXBundle.c9
-rw-r--r--macosx/tclMacOSXFCmd.c72
-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.test652
-rw-r--r--tests/case.test11
-rw-r--r--tests/chan.test10
-rw-r--r--tests/chanio.test244
-rw-r--r--tests/clock.test36
-rw-r--r--tests/cmdAH.test640
-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.test47
-rw-r--r--tests/encoding.test566
-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.test403
-rw-r--r--tests/fCmd.test329
-rw-r--r--tests/fileName.test108
-rw-r--r--tests/fileSystem.test39
-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.test125
-rw-r--r--tests/get.test35
-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.test6
-rw-r--r--tests/incr.test16
-rw-r--r--tests/indexObj.test59
-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.test814
-rw-r--r--tests/ioCmd.test246
-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.test509
-rw-r--r--tests/linsert.test6
-rw-r--r--tests/list.test20
-rw-r--r--tests/listObj.test74
-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.test333
-rw-r--r--tests/lsearch.test175
-rw-r--r--tests/lseq.test552
-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.test1386
-rw-r--r--tests/ooNext2.test4
-rw-r--r--tests/ooUtil.test563
-rw-r--r--tests/opt.test6
-rw-r--r--tests/package.test181
-rw-r--r--tests/parse.test28
-rw-r--r--tests/parseExpr.test63
-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.test10
-rw-r--r--tests/set.test6
-rw-r--r--tests/socket.test1104
-rw-r--r--tests/source.test47
-rw-r--r--tests/split.test21
-rw-r--r--tests/stack.test2
-rw-r--r--tests/string.test720
-rw-r--r--tests/stringComp.test801
-rw-r--r--tests/stringObj.test169
-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.tcl30
-rw-r--r--tests/thread.test12
-rw-r--r--tests/timer.test22
-rw-r--r--tests/tm.test5
-rw-r--r--tests/trace.test8
-rw-r--r--tests/unixFCmd.test26
-rw-r--r--tests/unixFile.test4
-rw-r--r--tests/unixForkEvent.test10
-rw-r--r--tests/unixInit.test38
-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.test389
-rw-r--r--tests/utfext.test101
-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.test17
-rw-r--r--tests/winFCmd.test126
-rw-r--r--tests/winFile.test32
-rw-r--r--tests/winNotify.test6
-rw-r--r--tests/winPipe.test39
-rw-r--r--tests/winTime.test6
-rw-r--r--tests/zipfs.test410
-rw-r--r--tests/zlib.test14
-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.tcl456
-rwxr-xr-xtools/tclZIC.tcl6
-rw-r--r--tools/tcltk-man2html-utils.tcl262
-rwxr-xr-xtools/tcltk-man2html.tcl134
-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.in379
-rw-r--r--unix/README4
-rwxr-xr-xunix/configure21767
-rw-r--r--unix/configure.ac (renamed from unix/configure.in)236
-rw-r--r--unix/dltest/Makefile.in15
-rw-r--r--unix/dltest/pkga.c17
-rw-r--r--unix/dltest/pkgb.c41
-rw-r--r--unix/dltest/pkgc.c15
-rw-r--r--unix/dltest/pkgd.c17
-rw-r--r--unix/dltest/pkge.c2
-rw-r--r--unix/dltest/pkgooa.c19
-rw-r--r--unix/dltest/pkgt.c116
-rw-r--r--unix/dltest/pkgua.c23
-rwxr-xr-xunix/installManPage43
-rw-r--r--unix/tcl.m4538
-rw-r--r--unix/tcl.pc.in2
-rw-r--r--unix/tcl.spec2
-rw-r--r--unix/tclAppInit.c19
-rw-r--r--unix/tclConfig.h.in112
-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.c74
-rw-r--r--unix/tclLoadDyld.c86
-rw-r--r--unix/tclLoadNext.c38
-rw-r--r--unix/tclLoadOSF.c40
-rw-r--r--unix/tclLoadShl.c40
-rw-r--r--unix/tclSelectNotfy.c1233
-rw-r--r--unix/tclUnixChan.c721
-rw-r--r--unix/tclUnixCompat.c29
-rw-r--r--unix/tclUnixEvent.c6
-rw-r--r--unix/tclUnixFCmd.c391
-rw-r--r--unix/tclUnixFile.c93
-rw-r--r--unix/tclUnixInit.c80
-rw-r--r--unix/tclUnixNotfy.c1504
-rw-r--r--unix/tclUnixPipe.c80
-rw-r--r--unix/tclUnixPort.h51
-rw-r--r--unix/tclUnixSock.c338
-rw-r--r--unix/tclUnixTest.c324
-rw-r--r--unix/tclUnixThrd.c285
-rw-r--r--unix/tclUnixThrd.h19
-rw-r--r--unix/tclUnixTime.c83
-rw-r--r--unix/tclXtNotify.c29
-rw-r--r--unix/tclXtTest.c4
-rw-r--r--unix/tclooConfig.sh2
-rw-r--r--win/Makefile.in311
-rw-r--r--win/README16
-rwxr-xr-x[-rw-r--r--]win/buildall.vc.bat8
-rw-r--r--win/coffbase.txt43
-rwxr-xr-xwin/configure8187
-rw-r--r--win/configure.ac (renamed from win/configure.in)129
-rw-r--r--win/makefile.vc265
-rw-r--r--win/nmakehlp.c18
-rw-r--r--win/rules.vc34
-rw-r--r--win/tcl.dsp54
-rw-r--r--win/tcl.hpj.in19
-rw-r--r--win/tcl.m4325
-rw-r--r--win/tcl.rc8
-rw-r--r--win/tclAppInit.c37
-rw-r--r--win/tclConfig.sh.in16
-rw-r--r--win/tclWin32Dll.c184
-rw-r--r--win/tclWinChan.c261
-rw-r--r--win/tclWinConsole.c2450
-rw-r--r--win/tclWinDde.c112
-rw-r--r--win/tclWinError.c17
-rw-r--r--win/tclWinFCmd.c249
-rw-r--r--win/tclWinFile.c202
-rw-r--r--win/tclWinInit.c64
-rw-r--r--win/tclWinInt.h47
-rw-r--r--win/tclWinLoad.c61
-rw-r--r--win/tclWinNotify.c501
-rw-r--r--win/tclWinPanic.c88
-rw-r--r--win/tclWinPipe.c220
-rw-r--r--win/tclWinPort.h68
-rw-r--r--win/tclWinReg.c134
-rw-r--r--win/tclWinSerial.c191
-rw-r--r--win/tclWinSock.c426
-rw-r--r--win/tclWinTest.c37
-rw-r--r--win/tclWinThrd.c104
-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
777 files changed, 108845 insertions, 70566 deletions
diff --git a/.fossil-settings/crlf-glob b/.fossil-settings/crlf-glob
index 48bf0d6..d98b4d6 100644
--- a/.fossil-settings/crlf-glob
+++ b/.fossil-settings/crlf-glob
@@ -10,7 +10,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
@@ -20,4 +19,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 4d7ce1b..29aa98b 100644
--- a/.github/workflows/linux-build.yml
+++ b/.github/workflows/linux-build.yml
@@ -15,12 +15,12 @@ jobs:
matrix:
cfgopt:
- ""
+ - "CFLAGS=-DTCL_UTF_MAX=3"
+ - "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
- - "CFLAGS=-DTCL_UTF_MAX=4"
- - "CFLAGS=-DTCL_UTF_MAX=6"
defaults:
run:
shell: bash
@@ -30,7 +30,7 @@ jobs:
uses: actions/checkout@v3
- 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 5e9b729..462bd92 100644
--- a/.github/workflows/mac-build.yml
+++ b/.github/workflows/mac-build.yml
@@ -20,10 +20,12 @@ jobs:
uses: actions/checkout@v3
- 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:
@@ -48,17 +50,20 @@ jobs:
uses: actions/checkout@v3
- 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..5c90701
--- /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@v3
+ - name: Prepare
+ run: |
+ touch generic/tclStubInit.c generic/tclOOStubInit.c
+ mkdir 1dist
+ echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
+ working-directory: .
+ - name: Configure
+ 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@v3
+ - name: Checkout create-dmg
+ uses: actions/checkout@v3
+ with:
+ repository: create-dmg/create-dmg
+ ref: v1.0.8
+ path: create-dmg
+ - name: Prepare
+ run: |
+ mkdir 1dist
+ 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@v3
+ - name: Prepare
+ run: |
+ touch generic/tclStubInit.c generic/tclOOStubInit.c
+ echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
+ mkdir 1dist
+ working-directory: .
+ - name: Configure
+ 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 dbc8fcc..3809786 100644
--- a/.github/workflows/win-build.yml
+++ b/.github/workflows/win-build.yml
@@ -21,7 +21,9 @@ jobs:
matrix:
cfgopt:
- ""
- - "OPTS=static,msvcrt"
+ - "OPTS=utf16"
+ - "CHECKS=nodep"
+ - "OPTS=static"
- "OPTS=symbols"
- "OPTS=symbols STATS=compdbg,memdbg"
# Using powershell means we need to explicitly stop on failure
@@ -58,6 +60,8 @@ jobs:
matrix:
cfgopt:
- ""
+ - "CFLAGS=-DTCL_UTF_MAX=3"
+ - "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
@@ -73,7 +77,7 @@ jobs:
uses: actions/checkout@v3
- 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 }}
@@ -87,3 +91,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..02fd9a3 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -27,13 +27,13 @@ jobs:
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=4
- - name: "Linux/GCC/Shared: UTF_MAX=6"
+ - name: "Linux/GCC/Shared: NO_DEPRECATED"
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 +83,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 +112,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 +122,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 +148,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 +208,40 @@ 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: UTF_MAX=4"
+ os: windows
+ compiler: cl
+ env: *vcenv
+ before_install: *vcpreinst
+ install: []
+ script:
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utf16' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utf16' '-f' makefile.vc test
+ - 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 +270,24 @@ 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: UTF_MAX=4"
+ os: windows
+ compiler: cl
+ env: *vcenv
+ before_install: *vcpreinst
+ install: []
+ script:
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utf16' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utf16' '-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 +295,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,8 +323,8 @@ 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"
os: windows
@@ -288,6 +333,13 @@ jobs:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=4"
before_install: *makepreinst
+ - name: "Windows/GCC/Shared: NO_DEPRECATED"
+ os: windows
+ compiler: gcc
+ env:
+ - BUILD_DIR=win
+ - CFGOPT="--enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1"
+ before_install: *makepreinst
- name: "Windows/GCC/Static"
os: windows
compiler: gcc
@@ -323,6 +375,13 @@ jobs:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=4"
before_install: *makepreinst
+ - name: "Windows/GCC-x86/Shared: NO_DEPRECATED"
+ os: windows
+ compiler: gcc
+ env:
+ - BUILD_DIR=win
+ - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
+ before_install: *makepreinst
- name: "Windows/GCC-x86/Static"
os: windows
compiler: gcc
@@ -354,7 +413,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.2003 b/ChangeLog.2003
index acdf81d..d0f4ebc 100644
--- a/ChangeLog.2003
+++ b/ChangeLog.2003
@@ -2331,7 +2331,7 @@
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
+ modified to accommodate 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]
@@ -2571,7 +2571,7 @@
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
+ * library/package.tcl: of -load patterns, to better accommodate common
user errors due to confusion between [package names] names and [info
loaded] names.
diff --git a/ChangeLog.2008 b/ChangeLog.2008
index 7bd2a01..7df6cbc 100644
--- a/ChangeLog.2008
+++ b/ChangeLog.2008
@@ -1939,7 +1939,7 @@
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/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,
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..75642de 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.
@@ -8796,6 +8796,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 +8995,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 +9232,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 +9256,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/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/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
index 07ef572..25a7ada 100644
--- a/compat/opendir.c
+++ b/compat/opendir.c
@@ -106,5 +106,5 @@ closedir(
close(dirp->dd_fd);
dirp->dd_fd = -1;
dirp->dd_loc = 0;
- ckfree((char *)dirp);
+ ckfree(dirp);
}
diff --git a/compat/stdint.h b/compat/stdint.h
new file mode 100644
index 0000000..88383b0
--- /dev/null
+++ b/compat/stdint.h
@@ -0,0 +1,919 @@
+/* A portable stdint.h
+ ****************************************************************************
+ * BSD License:
+ ****************************************************************************
+ *
+ * Copyright (c) 2005-2016 Paul Hsieh
+ * All rights reserved.
+ *
+ * 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 name of the author may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ *
+ ****************************************************************************
+ *
+ * Version 0.1.16.0
+ *
+ * The ANSI C standard committee, for the C99 standard, specified the
+ * inclusion of a new standard include file called stdint.h. This is
+ * a very useful and long desired include file which contains several
+ * very precise definitions for integer scalar types that is critically
+ * important for making several classes of applications portable
+ * including cryptography, hashing, variable length integer libraries
+ * and so on. But for most developers its likely useful just for
+ * programming sanity.
+ *
+ * The problem is that some compiler vendors chose to ignore the C99
+ * standard and some older compilers have no opportunity to be updated.
+ * Because of this situation, simply including stdint.h in your code
+ * makes it unportable.
+ *
+ * So that's what this file is all about. It's an attempt to build a
+ * single universal include file that works on as many platforms as
+ * possible to deliver what stdint.h is supposed to. Even compilers
+ * that already come with stdint.h can use this file instead without
+ * any loss of functionality. A few things that should be noted about
+ * this file:
+ *
+ * 1) It is not guaranteed to be portable and/or present an identical
+ * interface on all platforms. The extreme variability of the
+ * ANSI C standard makes this an impossibility right from the
+ * very get go. Its really only meant to be useful for the vast
+ * majority of platforms that possess the capability of
+ * implementing usefully and precisely defined, standard sized
+ * integer scalars. Systems which are not intrinsically 2s
+ * complement may produce invalid constants.
+ *
+ * 2) There is an unavoidable use of non-reserved symbols.
+ *
+ * 3) Other standard include files are invoked.
+ *
+ * 4) This file may come in conflict with future platforms that do
+ * include stdint.h. The hope is that one or the other can be
+ * used with no real difference.
+ *
+ * 5) In the current version, if your platform can't represent
+ * int32_t, int16_t and int8_t, it just dumps out with a compiler
+ * error.
+ *
+ * 6) 64 bit integers may or may not be defined. Test for their
+ * presence with the test: #ifdef INT64_MAX or #ifdef UINT64_MAX.
+ * Note that this is different from the C99 specification which
+ * requires the existence of 64 bit support in the compiler. If
+ * this is not defined for your platform, yet it is capable of
+ * dealing with 64 bits then it is because this file has not yet
+ * been extended to cover all of your system's capabilities.
+ *
+ * 7) (u)intptr_t may or may not be defined. Test for its presence
+ * with the test: #ifdef PTRDIFF_MAX. If this is not defined
+ * for your platform, then it is because this file has not yet
+ * been extended to cover all of your system's capabilities, not
+ * because its optional.
+ *
+ * 8) The following might not been defined even if your platform is
+ * capable of defining it:
+ *
+ * WCHAR_MIN
+ * WCHAR_MAX
+ * (u)int64_t
+ * PTRDIFF_MIN
+ * PTRDIFF_MAX
+ * (u)intptr_t
+ *
+ * 9) The following have not been defined:
+ *
+ * WINT_MIN
+ * WINT_MAX
+ *
+ * 10) The criteria for defining (u)int_least(*)_t isn't clear,
+ * except for systems which don't have a type that precisely
+ * defined 8, 16, or 32 bit types (which this include file does
+ * not support anyways). Default definitions have been given.
+ *
+ * 11) The criteria for defining (u)int_fast(*)_t isn't something I
+ * would trust to any particular compiler vendor or the ANSI C
+ * committee. It is well known that "compatible systems" are
+ * commonly created that have very different performance
+ * characteristics from the systems they are compatible with,
+ * especially those whose vendors make both the compiler and the
+ * system. Default definitions have been given, but its strongly
+ * recommended that users never use these definitions for any
+ * reason (they do *NOT* deliver any serious guarantee of
+ * improved performance -- not in this file, nor any vendor's
+ * stdint.h).
+ *
+ * 12) The following macros:
+ *
+ * PRINTF_INTMAX_MODIFIER
+ * PRINTF_INT64_MODIFIER
+ * PRINTF_INT32_MODIFIER
+ * PRINTF_INT16_MODIFIER
+ * PRINTF_LEAST64_MODIFIER
+ * PRINTF_LEAST32_MODIFIER
+ * PRINTF_LEAST16_MODIFIER
+ * PRINTF_INTPTR_MODIFIER
+ *
+ * are strings which have been defined as the modifiers required
+ * for the "d", "u" and "x" printf formats to correctly output
+ * (u)intmax_t, (u)int64_t, (u)int32_t, (u)int16_t, (u)least64_t,
+ * (u)least32_t, (u)least16_t and (u)intptr_t types respectively.
+ * PRINTF_INTPTR_MODIFIER is not defined for some systems which
+ * provide their own stdint.h. PRINTF_INT64_MODIFIER is not
+ * defined if INT64_MAX is not defined. These are an extension
+ * beyond what C99 specifies must be in stdint.h.
+ *
+ * In addition, the following macros are defined:
+ *
+ * PRINTF_INTMAX_HEX_WIDTH
+ * PRINTF_INT64_HEX_WIDTH
+ * PRINTF_INT32_HEX_WIDTH
+ * PRINTF_INT16_HEX_WIDTH
+ * PRINTF_INT8_HEX_WIDTH
+ * PRINTF_INTMAX_DEC_WIDTH
+ * PRINTF_INT64_DEC_WIDTH
+ * PRINTF_INT32_DEC_WIDTH
+ * PRINTF_INT16_DEC_WIDTH
+ * PRINTF_UINT8_DEC_WIDTH
+ * PRINTF_UINTMAX_DEC_WIDTH
+ * PRINTF_UINT64_DEC_WIDTH
+ * PRINTF_UINT32_DEC_WIDTH
+ * PRINTF_UINT16_DEC_WIDTH
+ * PRINTF_UINT8_DEC_WIDTH
+ *
+ * Which specifies the maximum number of characters required to
+ * print the number of that type in either hexadecimal or decimal.
+ * These are an extension beyond what C99 specifies must be in
+ * stdint.h.
+ *
+ * Compilers tested (all with 0 warnings at their highest respective
+ * settings): Borland Turbo C 2.0, WATCOM C/C++ 11.0 (16 bits and 32
+ * bits), Microsoft Visual C++ 6.0 (32 bit), Microsoft Visual Studio
+ * .net (VC7), Intel C++ 4.0, GNU gcc v3.3.3
+ *
+ * This file should be considered a work in progress. Suggestions for
+ * improvements, especially those which increase coverage are strongly
+ * encouraged.
+ *
+ * Acknowledgements
+ *
+ * The following people have made significant contributions to the
+ * development and testing of this file:
+ *
+ * Chris Howie
+ * John Steele Scott
+ * Dave Thorup
+ * John Dill
+ * Florian Wobbe
+ * Christopher Sean Morrison
+ * Mikkel Fahnoe Jorgensen
+ *
+ */
+
+#include <stddef.h>
+#include <limits.h>
+#include <signal.h>
+
+/*
+ * For gcc with _STDINT_H, fill in the PRINTF_INT*_MODIFIER macros, and
+ * do nothing else. On the Mac OS X version of gcc this is _STDINT_H_.
+ */
+
+#if ((defined(__SUNPRO_C) && __SUNPRO_C >= 0x570) || (defined(_MSC_VER) && _MSC_VER >= 1600) || (defined(__STDC__) && __STDC__ && defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || (defined (__WATCOMC__) && (defined (_STDINT_H_INCLUDED) || __WATCOMC__ >= 1250)) || (defined(__GNUC__) && (__GNUC__ > 3 || defined(_STDINT_H) || defined(_STDINT_H_) || defined (__UINT_FAST64_TYPE__)) )) && !defined (_PSTDINT_H_INCLUDED)
+#include <stdint.h>
+#define _PSTDINT_H_INCLUDED
+# if defined(__GNUC__) && (defined(__x86_64__) || defined(__ppc64__)) && !(defined(__APPLE__) && defined(__MACH__))
+# ifndef PRINTF_INT64_MODIFIER
+# define PRINTF_INT64_MODIFIER "l"
+# endif
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER ""
+# endif
+# else
+# ifndef PRINTF_INT64_MODIFIER
+# define PRINTF_INT64_MODIFIER "ll"
+# endif
+# ifndef PRINTF_INT32_MODIFIER
+# if (UINT_MAX == UINT32_MAX)
+# define PRINTF_INT32_MODIFIER ""
+# else
+# define PRINTF_INT32_MODIFIER "l"
+# endif
+# endif
+# endif
+# ifndef PRINTF_INT16_MODIFIER
+# define PRINTF_INT16_MODIFIER "h"
+# endif
+# ifndef PRINTF_INTMAX_MODIFIER
+# define PRINTF_INTMAX_MODIFIER PRINTF_INT64_MODIFIER
+# endif
+# ifndef PRINTF_INT64_HEX_WIDTH
+# define PRINTF_INT64_HEX_WIDTH "16"
+# endif
+# ifndef PRINTF_UINT64_HEX_WIDTH
+# define PRINTF_UINT64_HEX_WIDTH "16"
+# endif
+# ifndef PRINTF_INT32_HEX_WIDTH
+# define PRINTF_INT32_HEX_WIDTH "8"
+# endif
+# ifndef PRINTF_UINT32_HEX_WIDTH
+# define PRINTF_UINT32_HEX_WIDTH "8"
+# endif
+# ifndef PRINTF_INT16_HEX_WIDTH
+# define PRINTF_INT16_HEX_WIDTH "4"
+# endif
+# ifndef PRINTF_UINT16_HEX_WIDTH
+# define PRINTF_UINT16_HEX_WIDTH "4"
+# endif
+# ifndef PRINTF_INT8_HEX_WIDTH
+# define PRINTF_INT8_HEX_WIDTH "2"
+# endif
+# ifndef PRINTF_UINT8_HEX_WIDTH
+# define PRINTF_UINT8_HEX_WIDTH "2"
+# endif
+# ifndef PRINTF_INT64_DEC_WIDTH
+# define PRINTF_INT64_DEC_WIDTH "19"
+# endif
+# ifndef PRINTF_UINT64_DEC_WIDTH
+# define PRINTF_UINT64_DEC_WIDTH "20"
+# endif
+# ifndef PRINTF_INT32_DEC_WIDTH
+# define PRINTF_INT32_DEC_WIDTH "10"
+# endif
+# ifndef PRINTF_UINT32_DEC_WIDTH
+# define PRINTF_UINT32_DEC_WIDTH "10"
+# endif
+# ifndef PRINTF_INT16_DEC_WIDTH
+# define PRINTF_INT16_DEC_WIDTH "5"
+# endif
+# ifndef PRINTF_UINT16_DEC_WIDTH
+# define PRINTF_UINT16_DEC_WIDTH "5"
+# endif
+# ifndef PRINTF_INT8_DEC_WIDTH
+# define PRINTF_INT8_DEC_WIDTH "3"
+# endif
+# ifndef PRINTF_UINT8_DEC_WIDTH
+# define PRINTF_UINT8_DEC_WIDTH "3"
+# endif
+# ifndef PRINTF_INTMAX_HEX_WIDTH
+# define PRINTF_INTMAX_HEX_WIDTH PRINTF_UINT64_HEX_WIDTH
+# endif
+# ifndef PRINTF_UINTMAX_HEX_WIDTH
+# define PRINTF_UINTMAX_HEX_WIDTH PRINTF_UINT64_HEX_WIDTH
+# endif
+# ifndef PRINTF_INTMAX_DEC_WIDTH
+# define PRINTF_INTMAX_DEC_WIDTH PRINTF_UINT64_DEC_WIDTH
+# endif
+# ifndef PRINTF_UINTMAX_DEC_WIDTH
+# define PRINTF_UINTMAX_DEC_WIDTH PRINTF_UINT64_DEC_WIDTH
+# endif
+
+/*
+ * Something really weird is going on with Open Watcom. Just pull some of
+ * these duplicated definitions from Open Watcom's stdint.h file for now.
+ */
+
+# if defined (__WATCOMC__) && __WATCOMC__ >= 1250
+# if !defined (INT64_C)
+# define INT64_C(x) (x + (INT64_MAX - INT64_MAX))
+# endif
+# if !defined (UINT64_C)
+# define UINT64_C(x) (x + (UINT64_MAX - UINT64_MAX))
+# endif
+# if !defined (INT32_C)
+# define INT32_C(x) (x + (INT32_MAX - INT32_MAX))
+# endif
+# if !defined (UINT32_C)
+# define UINT32_C(x) (x + (UINT32_MAX - UINT32_MAX))
+# endif
+# if !defined (INT16_C)
+# define INT16_C(x) (x)
+# endif
+# if !defined (UINT16_C)
+# define UINT16_C(x) (x)
+# endif
+# if !defined (INT8_C)
+# define INT8_C(x) (x)
+# endif
+# if !defined (UINT8_C)
+# define UINT8_C(x) (x)
+# endif
+# if !defined (UINT64_MAX)
+# define UINT64_MAX 18446744073709551615ULL
+# endif
+# if !defined (INT64_MAX)
+# define INT64_MAX 9223372036854775807LL
+# endif
+# if !defined (UINT32_MAX)
+# define UINT32_MAX 4294967295UL
+# endif
+# if !defined (INT32_MAX)
+# define INT32_MAX 2147483647L
+# endif
+# if !defined (INTMAX_MAX)
+# define INTMAX_MAX INT64_MAX
+# endif
+# if !defined (INTMAX_MIN)
+# define INTMAX_MIN INT64_MIN
+# endif
+# endif
+#endif
+
+/*
+ * I have no idea what is the truly correct thing to do on older Solaris.
+ * From some online discussions, this seems to be what is being
+ * recommended. For people who actually are developing on older Solaris,
+ * what I would like to know is, does this define all of the relevant
+ * macros of a complete stdint.h? Remember, in pstdint.h 64 bit is
+ * considered optional.
+ */
+
+#if (defined(__SUNPRO_C) && __SUNPRO_C >= 0x420) && !defined(_PSTDINT_H_INCLUDED)
+#include <sys/inttypes.h>
+#define _PSTDINT_H_INCLUDED
+#endif
+
+#ifndef _PSTDINT_H_INCLUDED
+#define _PSTDINT_H_INCLUDED
+
+#ifndef SIZE_MAX
+# define SIZE_MAX ((size_t)-1)
+#endif
+
+/*
+ * Deduce the type assignments from limits.h under the assumption that
+ * integer sizes in bits are powers of 2, and follow the ANSI
+ * definitions.
+ */
+
+#ifndef UINT8_MAX
+# define UINT8_MAX 0xff
+#endif
+#if !defined(uint8_t) && !defined(_UINT8_T) && !defined(vxWorks)
+# if (UCHAR_MAX == UINT8_MAX) || defined (S_SPLINT_S)
+ typedef unsigned char uint8_t;
+# define UINT8_C(v) ((uint8_t) v)
+# else
+# error "Platform not supported"
+# endif
+#endif
+
+#ifndef INT8_MAX
+# define INT8_MAX 0x7f
+#endif
+#ifndef INT8_MIN
+# define INT8_MIN INT8_C(0x80)
+#endif
+#if !defined(int8_t) && !defined(_INT8_T) && !defined(vxWorks)
+# if (SCHAR_MAX == INT8_MAX) || defined (S_SPLINT_S)
+ typedef signed char int8_t;
+# define INT8_C(v) ((int8_t) v)
+# else
+# error "Platform not supported"
+# endif
+#endif
+
+#ifndef UINT16_MAX
+# define UINT16_MAX 0xffff
+#endif
+#if !defined(uint16_t) && !defined(_UINT16_T) && !defined(vxWorks)
+#if (UINT_MAX == UINT16_MAX) || defined (S_SPLINT_S)
+ typedef unsigned int uint16_t;
+# ifndef PRINTF_INT16_MODIFIER
+# define PRINTF_INT16_MODIFIER ""
+# endif
+# define UINT16_C(v) ((uint16_t) (v))
+#elif (USHRT_MAX == UINT16_MAX)
+ typedef unsigned short uint16_t;
+# define UINT16_C(v) ((uint16_t) (v))
+# ifndef PRINTF_INT16_MODIFIER
+# define PRINTF_INT16_MODIFIER "h"
+# endif
+#else
+#error "Platform not supported"
+#endif
+#endif
+
+#ifndef INT16_MAX
+# define INT16_MAX 0x7fff
+#endif
+#ifndef INT16_MIN
+# define INT16_MIN INT16_C(0x8000)
+#endif
+#if !defined(int16_t) && !defined(_INT16_T) && !defined(vxWorks)
+#if (INT_MAX == INT16_MAX) || defined (S_SPLINT_S)
+ typedef signed int int16_t;
+# define INT16_C(v) ((int16_t) (v))
+# ifndef PRINTF_INT16_MODIFIER
+# define PRINTF_INT16_MODIFIER ""
+# endif
+#elif (SHRT_MAX == INT16_MAX)
+ typedef signed short int16_t;
+# define INT16_C(v) ((int16_t) (v))
+# ifndef PRINTF_INT16_MODIFIER
+# define PRINTF_INT16_MODIFIER "h"
+# endif
+#else
+#error "Platform not supported"
+#endif
+#endif
+
+#ifndef UINT32_MAX
+# define UINT32_MAX (0xffffffffUL)
+#endif
+#if !defined(uint32_t) && !defined(_UINT32_T) && !defined(vxWorks)
+#if (ULONG_MAX == UINT32_MAX) || defined (S_SPLINT_S)
+ typedef unsigned long uint32_t;
+# define UINT32_C(v) v ## UL
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER "l"
+# endif
+#elif (UINT_MAX == UINT32_MAX)
+ typedef unsigned int uint32_t;
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER ""
+# endif
+# define UINT32_C(v) v ## U
+#elif (USHRT_MAX == UINT32_MAX)
+ typedef unsigned short uint32_t;
+# define UINT32_C(v) ((unsigned short) (v))
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER ""
+# endif
+#else
+#error "Platform not supported"
+#endif
+#endif
+
+#ifndef INT32_MAX
+# define INT32_MAX (0x7fffffffL)
+#endif
+#ifndef INT32_MIN
+# define INT32_MIN INT32_C(0x80000000)
+#endif
+#if !defined(int32_t) && !defined(_INT32_T) && !defined(vxWorks)
+#if (LONG_MAX == INT32_MAX) || defined (S_SPLINT_S)
+ typedef signed long int32_t;
+# define INT32_C(v) v ## L
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER "l"
+# endif
+#elif (INT_MAX == INT32_MAX)
+ typedef signed int int32_t;
+# define INT32_C(v) v
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER ""
+# endif
+#elif (SHRT_MAX == INT32_MAX)
+ typedef signed short int32_t;
+# define INT32_C(v) ((short) (v))
+# ifndef PRINTF_INT32_MODIFIER
+# define PRINTF_INT32_MODIFIER ""
+# endif
+#else
+#error "Platform not supported"
+#endif
+#endif
+
+/*
+ * The macro stdint_int64_defined is temporarily used to record
+ * whether or not 64 integer support is available. It must be
+ * defined for any 64 integer extensions for new platforms that are
+ * added.
+ */
+
+#undef stdint_int64_defined
+#if (defined(__STDC__) && defined(__STDC_VERSION__)) || defined (S_SPLINT_S)
+# if (__STDC__ && __STDC_VERSION__ >= 199901L) || defined (S_SPLINT_S)
+# define stdint_int64_defined
+ typedef long long int64_t;
+ typedef unsigned long long uint64_t;
+# define UINT64_C(v) v ## ULL
+# define INT64_C(v) v ## LL
+# ifndef PRINTF_INT64_MODIFIER
+# define PRINTF_INT64_MODIFIER "ll"
+# endif
+# endif
+#endif
+
+#if !defined (stdint_int64_defined)
+# if defined(__GNUC__) && !defined(vxWorks)
+# define stdint_int64_defined
+ __extension__ typedef long long int64_t;
+ __extension__ typedef unsigned long long uint64_t;
+# define UINT64_C(v) v ## ULL
+# define INT64_C(v) v ## LL
+# ifndef PRINTF_INT64_MODIFIER
+# define PRINTF_INT64_MODIFIER "ll"
+# endif
+# elif defined(__MWERKS__) || defined (__SUNPRO_C) || defined (__SUNPRO_CC) || defined (__APPLE_CC__) || defined (_LONG_LONG) || defined (_CRAYC) || defined (S_SPLINT_S)
+# define stdint_int64_defined
+ typedef long long int64_t;
+ typedef unsigned long long uint64_t;
+# define UINT64_C(v) v ## ULL
+# define INT64_C(v) v ## LL
+# ifndef PRINTF_INT64_MODIFIER
+# define PRINTF_INT64_MODIFIER "ll"
+# endif
+# elif (defined(__WATCOMC__) && defined(__WATCOM_INT64__)) || (defined(_MSC_VER) && _INTEGRAL_MAX_BITS >= 64) || (defined (__BORLANDC__) && __BORLANDC__ > 0x460) || defined (__alpha) || defined (__DECC)
+# define stdint_int64_defined
+ typedef __int64 int64_t;
+ typedef unsigned __int64 uint64_t;
+# define UINT64_C(v) v ## UI64
+# define INT64_C(v) v ## I64
+# ifndef PRINTF_INT64_MODIFIER
+# define PRINTF_INT64_MODIFIER "I64"
+# endif
+# endif
+#endif
+
+#if !defined (LONG_LONG_MAX) && defined (INT64_C)
+# define LONG_LONG_MAX INT64_C (9223372036854775807)
+#endif
+#ifndef ULONG_LONG_MAX
+# define ULONG_LONG_MAX UINT64_C (18446744073709551615)
+#endif
+
+#if !defined (INT64_MAX) && defined (INT64_C)
+# define INT64_MAX INT64_C (9223372036854775807)
+#endif
+#if !defined (INT64_MIN) && defined (INT64_C)
+# define INT64_MIN INT64_C (-9223372036854775808)
+#endif
+#if !defined (UINT64_MAX) && defined (INT64_C)
+# define UINT64_MAX UINT64_C (18446744073709551615)
+#endif
+
+/*
+ * Width of hexadecimal for number field.
+ */
+
+#ifndef PRINTF_INT64_HEX_WIDTH
+# define PRINTF_INT64_HEX_WIDTH "16"
+#endif
+#ifndef PRINTF_INT32_HEX_WIDTH
+# define PRINTF_INT32_HEX_WIDTH "8"
+#endif
+#ifndef PRINTF_INT16_HEX_WIDTH
+# define PRINTF_INT16_HEX_WIDTH "4"
+#endif
+#ifndef PRINTF_INT8_HEX_WIDTH
+# define PRINTF_INT8_HEX_WIDTH "2"
+#endif
+#ifndef PRINTF_INT64_DEC_WIDTH
+# define PRINTF_INT64_DEC_WIDTH "19"
+#endif
+#ifndef PRINTF_INT32_DEC_WIDTH
+# define PRINTF_INT32_DEC_WIDTH "10"
+#endif
+#ifndef PRINTF_INT16_DEC_WIDTH
+# define PRINTF_INT16_DEC_WIDTH "5"
+#endif
+#ifndef PRINTF_INT8_DEC_WIDTH
+# define PRINTF_INT8_DEC_WIDTH "3"
+#endif
+#ifndef PRINTF_UINT64_DEC_WIDTH
+# define PRINTF_UINT64_DEC_WIDTH "20"
+#endif
+#ifndef PRINTF_UINT32_DEC_WIDTH
+# define PRINTF_UINT32_DEC_WIDTH "10"
+#endif
+#ifndef PRINTF_UINT16_DEC_WIDTH
+# define PRINTF_UINT16_DEC_WIDTH "5"
+#endif
+#ifndef PRINTF_UINT8_DEC_WIDTH
+# define PRINTF_UINT8_DEC_WIDTH "3"
+#endif
+
+/*
+ * Ok, lets not worry about 128 bit integers for now. Moore's law says
+ * we don't need to worry about that until about 2040 at which point
+ * we'll have bigger things to worry about.
+ */
+
+#ifdef stdint_int64_defined
+ typedef int64_t intmax_t;
+ typedef uint64_t uintmax_t;
+# define INTMAX_MAX INT64_MAX
+# define INTMAX_MIN INT64_MIN
+# define UINTMAX_MAX UINT64_MAX
+# define UINTMAX_C(v) UINT64_C(v)
+# define INTMAX_C(v) INT64_C(v)
+# ifndef PRINTF_INTMAX_MODIFIER
+# define PRINTF_INTMAX_MODIFIER PRINTF_INT64_MODIFIER
+# endif
+# ifndef PRINTF_INTMAX_HEX_WIDTH
+# define PRINTF_INTMAX_HEX_WIDTH PRINTF_INT64_HEX_WIDTH
+# endif
+# ifndef PRINTF_INTMAX_DEC_WIDTH
+# define PRINTF_INTMAX_DEC_WIDTH PRINTF_INT64_DEC_WIDTH
+# endif
+#else
+ typedef int32_t intmax_t;
+ typedef uint32_t uintmax_t;
+# define INTMAX_MAX INT32_MAX
+# define UINTMAX_MAX UINT32_MAX
+# define UINTMAX_C(v) UINT32_C(v)
+# define INTMAX_C(v) INT32_C(v)
+# ifndef PRINTF_INTMAX_MODIFIER
+# define PRINTF_INTMAX_MODIFIER PRINTF_INT32_MODIFIER
+# endif
+# ifndef PRINTF_INTMAX_HEX_WIDTH
+# define PRINTF_INTMAX_HEX_WIDTH PRINTF_INT32_HEX_WIDTH
+# endif
+# ifndef PRINTF_INTMAX_DEC_WIDTH
+# define PRINTF_INTMAX_DEC_WIDTH PRINTF_INT32_DEC_WIDTH
+# endif
+#endif
+
+/*
+ * Because this file currently only supports platforms which have
+ * precise powers of 2 as bit sizes for the default integers, the
+ * least definitions are all trivial. Its possible that a future
+ * version of this file could have different definitions.
+ */
+
+#ifndef stdint_least_defined
+ typedef int8_t int_least8_t;
+ typedef uint8_t uint_least8_t;
+ typedef int16_t int_least16_t;
+ typedef uint16_t uint_least16_t;
+ typedef int32_t int_least32_t;
+ typedef uint32_t uint_least32_t;
+# define PRINTF_LEAST32_MODIFIER PRINTF_INT32_MODIFIER
+# define PRINTF_LEAST16_MODIFIER PRINTF_INT16_MODIFIER
+# define UINT_LEAST8_MAX UINT8_MAX
+# define INT_LEAST8_MAX INT8_MAX
+# define UINT_LEAST16_MAX UINT16_MAX
+# define INT_LEAST16_MAX INT16_MAX
+# define UINT_LEAST32_MAX UINT32_MAX
+# define INT_LEAST32_MAX INT32_MAX
+# define INT_LEAST8_MIN INT8_MIN
+# define INT_LEAST16_MIN INT16_MIN
+# define INT_LEAST32_MIN INT32_MIN
+# ifdef stdint_int64_defined
+ typedef int64_t int_least64_t;
+ typedef uint64_t uint_least64_t;
+# define PRINTF_LEAST64_MODIFIER PRINTF_INT64_MODIFIER
+# define UINT_LEAST64_MAX UINT64_MAX
+# define INT_LEAST64_MAX INT64_MAX
+# define INT_LEAST64_MIN INT64_MIN
+# endif
+#endif
+#undef stdint_least_defined
+
+/*
+ * The ANSI C committee has defined *int*_fast*_t types as well. This,
+ * of course, defies rationality -- you can't know what will be fast
+ * just from the type itself. Even for a given architecture, compatible
+ * implementations might have different performance characteristics.
+ * Developers are warned to stay away from these types when using this
+ * or any other stdint.h.
+ */
+
+typedef int_least8_t int_fast8_t;
+typedef uint_least8_t uint_fast8_t;
+typedef int_least16_t int_fast16_t;
+typedef uint_least16_t uint_fast16_t;
+typedef int_least32_t int_fast32_t;
+typedef uint_least32_t uint_fast32_t;
+#define UINT_FAST8_MAX UINT_LEAST8_MAX
+#define INT_FAST8_MAX INT_LEAST8_MAX
+#define UINT_FAST16_MAX UINT_LEAST16_MAX
+#define INT_FAST16_MAX INT_LEAST16_MAX
+#define UINT_FAST32_MAX UINT_LEAST32_MAX
+#define INT_FAST32_MAX INT_LEAST32_MAX
+#define INT_FAST8_MIN INT_LEAST8_MIN
+#define INT_FAST16_MIN INT_LEAST16_MIN
+#define INT_FAST32_MIN INT_LEAST32_MIN
+#ifdef stdint_int64_defined
+ typedef int_least64_t int_fast64_t;
+ typedef uint_least64_t uint_fast64_t;
+# define UINT_FAST64_MAX UINT_LEAST64_MAX
+# define INT_FAST64_MAX INT_LEAST64_MAX
+# define INT_FAST64_MIN INT_LEAST64_MIN
+#endif
+
+#undef stdint_int64_defined
+
+/*
+ * Whatever piecemeal, per compiler thing we can do about the wchar_t
+ * type limits.
+ */
+
+#if defined(__WATCOMC__) || defined(_MSC_VER) || defined (__GNUC__) && !defined(vxWorks)
+# include <wchar.h>
+# ifndef WCHAR_MIN
+# define WCHAR_MIN 0
+# endif
+# ifndef WCHAR_MAX
+# define WCHAR_MAX ((wchar_t)-1)
+# endif
+#endif
+
+/*
+ * Whatever piecemeal, per compiler/platform thing we can do about the
+ * (u)intptr_t types and limits.
+ */
+
+#if (defined (_MSC_VER) && defined (_UINTPTR_T_DEFINED)) || defined (_UINTPTR_T)
+# define STDINT_H_UINTPTR_T_DEFINED
+#endif
+
+#ifndef STDINT_H_UINTPTR_T_DEFINED
+# if defined (__alpha__) || defined (__ia64__) || defined (__x86_64__) || defined (_WIN64) || defined (__ppc64__)
+# define stdint_intptr_bits 64
+# elif defined (__WATCOMC__) || defined (__TURBOC__)
+# if defined(__TINY__) || defined(__SMALL__) || defined(__MEDIUM__)
+# define stdint_intptr_bits 16
+# else
+# define stdint_intptr_bits 32
+# endif
+# elif defined (__i386__) || defined (_WIN32) || defined (WIN32) || defined (__ppc64__)
+# define stdint_intptr_bits 32
+# elif defined (__INTEL_COMPILER)
+/* TODO -- what did Intel do about x86-64? */
+# else
+/* #error "This platform might not be supported yet" */
+# endif
+
+# ifdef stdint_intptr_bits
+# define stdint_intptr_glue3_i(a,b,c) a##b##c
+# define stdint_intptr_glue3(a,b,c) stdint_intptr_glue3_i(a,b,c)
+# ifndef PRINTF_INTPTR_MODIFIER
+# define PRINTF_INTPTR_MODIFIER stdint_intptr_glue3(PRINTF_INT,stdint_intptr_bits,_MODIFIER)
+# endif
+# ifndef PTRDIFF_MAX
+# define PTRDIFF_MAX stdint_intptr_glue3(INT,stdint_intptr_bits,_MAX)
+# endif
+# ifndef PTRDIFF_MIN
+# define PTRDIFF_MIN stdint_intptr_glue3(INT,stdint_intptr_bits,_MIN)
+# endif
+# ifndef UINTPTR_MAX
+# define UINTPTR_MAX stdint_intptr_glue3(UINT,stdint_intptr_bits,_MAX)
+# endif
+# ifndef INTPTR_MAX
+# define INTPTR_MAX stdint_intptr_glue3(INT,stdint_intptr_bits,_MAX)
+# endif
+# ifndef INTPTR_MIN
+# define INTPTR_MIN stdint_intptr_glue3(INT,stdint_intptr_bits,_MIN)
+# endif
+# ifndef INTPTR_C
+# define INTPTR_C(x) stdint_intptr_glue3(INT,stdint_intptr_bits,_C)(x)
+# endif
+# ifndef UINTPTR_C
+# define UINTPTR_C(x) stdint_intptr_glue3(UINT,stdint_intptr_bits,_C)(x)
+# endif
+ typedef stdint_intptr_glue3(uint,stdint_intptr_bits,_t) uintptr_t;
+ typedef stdint_intptr_glue3( int,stdint_intptr_bits,_t) intptr_t;
+# else
+/* TODO -- This following is likely wrong for some platforms, and does
+ nothing for the definition of uintptr_t. */
+ typedef ptrdiff_t intptr_t;
+# endif
+# define STDINT_H_UINTPTR_T_DEFINED
+#endif
+
+/*
+ * Assumes sig_atomic_t is signed and we have a 2s complement machine.
+ */
+
+#ifndef SIG_ATOMIC_MAX
+# define SIG_ATOMIC_MAX ((((sig_atomic_t) 1) << (sizeof (sig_atomic_t)*CHAR_BIT-1)) - 1)
+#endif
+
+#endif
+
+#if defined (__TEST_PSTDINT_FOR_CORRECTNESS)
+
+/*
+ * Please compile with the maximum warning settings to make sure macros are
+ * not defined more than once.
+ */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#define glue3_aux(x,y,z) x ## y ## z
+#define glue3(x,y,z) glue3_aux(x,y,z)
+
+#define DECLU(bits) glue3(uint,bits,_t) glue3(u,bits,) = glue3(UINT,bits,_C) (0);
+#define DECLI(bits) glue3(int,bits,_t) glue3(i,bits,) = glue3(INT,bits,_C) (0);
+
+#define DECL(us,bits) glue3(DECL,us,) (bits)
+
+#define TESTUMAX(bits) glue3(u,bits,) = ~glue3(u,bits,); if (glue3(UINT,bits,_MAX) != glue3(u,bits,)) printf ("Something wrong with UINT%d_MAX\n", bits)
+
+#define REPORTERROR(msg) { err_n++; if (err_first <= 0) err_first = __LINE__; printf msg; }
+
+#define X_SIZE_MAX ((size_t)-1)
+
+int main () {
+ int err_n = 0;
+ int err_first = 0;
+ DECL(I,8)
+ DECL(U,8)
+ DECL(I,16)
+ DECL(U,16)
+ DECL(I,32)
+ DECL(U,32)
+#ifdef INT64_MAX
+ DECL(I,64)
+ DECL(U,64)
+#endif
+ intmax_t imax = INTMAX_C(0);
+ uintmax_t umax = UINTMAX_C(0);
+ char str0[256], str1[256];
+
+ sprintf (str0, "%" PRINTF_INT32_MODIFIER "d", INT32_C(2147483647));
+ if (0 != strcmp (str0, "2147483647")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str0));
+ if (atoi(PRINTF_INT32_DEC_WIDTH) != (int) strlen(str0)) REPORTERROR (("Something wrong with PRINTF_INT32_DEC_WIDTH : %s\n", PRINTF_INT32_DEC_WIDTH));
+ sprintf (str0, "%" PRINTF_INT32_MODIFIER "u", UINT32_C(4294967295));
+ if (0 != strcmp (str0, "4294967295")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str0));
+ if (atoi(PRINTF_UINT32_DEC_WIDTH) != (int) strlen(str0)) REPORTERROR (("Something wrong with PRINTF_UINT32_DEC_WIDTH : %s\n", PRINTF_UINT32_DEC_WIDTH));
+#ifdef INT64_MAX
+ sprintf (str1, "%" PRINTF_INT64_MODIFIER "d", INT64_C(9223372036854775807));
+ if (0 != strcmp (str1, "9223372036854775807")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str1));
+ if (atoi(PRINTF_INT64_DEC_WIDTH) != (int) strlen(str1)) REPORTERROR (("Something wrong with PRINTF_INT64_DEC_WIDTH : %s, %d\n", PRINTF_INT64_DEC_WIDTH, (int) strlen(str1)));
+ sprintf (str1, "%" PRINTF_INT64_MODIFIER "u", UINT64_C(18446744073709550591));
+ if (0 != strcmp (str1, "18446744073709550591")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str1));
+ if (atoi(PRINTF_UINT64_DEC_WIDTH) != (int) strlen(str1)) REPORTERROR (("Something wrong with PRINTF_UINT64_DEC_WIDTH : %s, %d\n", PRINTF_UINT64_DEC_WIDTH, (int) strlen(str1)));
+#endif
+
+ sprintf (str0, "%d %x\n", 0, ~0);
+
+ sprintf (str1, "%d %x\n", i8, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i8 : %s\n", str1));
+ sprintf (str1, "%u %x\n", u8, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with u8 : %s\n", str1));
+ sprintf (str1, "%d %x\n", i16, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i16 : %s\n", str1));
+ sprintf (str1, "%u %x\n", u16, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with u16 : %s\n", str1));
+ sprintf (str1, "%" PRINTF_INT32_MODIFIER "d %x\n", i32, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i32 : %s\n", str1));
+ sprintf (str1, "%" PRINTF_INT32_MODIFIER "u %x\n", u32, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with u32 : %s\n", str1));
+#ifdef INT64_MAX
+ sprintf (str1, "%" PRINTF_INT64_MODIFIER "d %x\n", i64, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i64 : %s\n", str1));
+#endif
+ sprintf (str1, "%" PRINTF_INTMAX_MODIFIER "d %x\n", imax, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with imax : %s\n", str1));
+ sprintf (str1, "%" PRINTF_INTMAX_MODIFIER "u %x\n", umax, ~0);
+ if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with umax : %s\n", str1));
+
+ TESTUMAX(8);
+ TESTUMAX(16);
+ TESTUMAX(32);
+#ifdef INT64_MAX
+ TESTUMAX(64);
+#endif
+
+#define STR(v) #v
+#define Q(v) printf ("sizeof " STR(v) " = %u\n", (unsigned) sizeof (v));
+ if (err_n) {
+ printf ("pstdint.h is not correct. Please use sizes below to correct it:\n");
+ }
+
+ Q(int)
+ Q(unsigned)
+ Q(long int)
+ Q(short int)
+ Q(int8_t)
+ Q(int16_t)
+ Q(int32_t)
+#ifdef INT64_MAX
+ Q(int64_t)
+#endif
+
+#if UINT_MAX < X_SIZE_MAX
+ printf ("UINT_MAX < X_SIZE_MAX\n");
+#else
+ printf ("UINT_MAX >= X_SIZE_MAX\n");
+#endif
+ printf ("%" PRINTF_INT64_MODIFIER "u vs %" PRINTF_INT64_MODIFIER "u\n", UINT_MAX, X_SIZE_MAX);
+
+ return EXIT_SUCCESS;
+}
+
+#endif
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/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 6f43934..626d210 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/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 35ed527..3e88520 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 d6580be..53f134a 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..639018c 100644
--- a/doc/ByteArrObj.3
+++ b/doc/ByteArrObj.3
@@ -8,84 +8,184 @@
.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 "ptrdiff_t | int" *numBytesPtr out
+Points to space where the number of bytes in the array may be written.
+Caller may pass NULL when it does not need this information.
.BE
.SH DESCRIPTION
.PP
-These 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. This space may be of type
+\fBptrdiff_t\fR or of type \fBint\fR. In Tcl 8, the largest number of
+bytes possible is \fBINT_MAX\fR, so either type can receive the value.
+In codebases meant to migrate to Tcl 9, the option to write to a space
+of type \fBptrdiff_t\fR may aid in the migration.
+.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..1481e81 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,
+ ptrdiff_t \fIobjc\fR,
+ Tcl_Obj *const \fIobjv\fR[]);
+.CE
+.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
\fIinterp\fR will result in errors.
@@ -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..ba5a991 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,
+ ptrdiff_t \fIlevel\fR,
+ const char *\fIcommand\fR,
+ \fBTcl_Command\fR \fIcommandToken\fR,
+ ptrdiff_t \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..66323a7 100644
--- a/doc/DString.3
+++ b/doc/DString.3
@@ -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..7453549 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 Tcl_Size *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,28 @@ 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_ERROR\fR with the
+converted string stored in \fB*dstPtr\fR. For errors other than conversion
+errors, such as invalid flags, the function returns \fBTCL_OK\fR with an error
+message in \fBinterp\fR if it is not NULL.
+.PP
+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 whatever is
+decoded 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 +267,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 +284,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 +302,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 +320,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 +370,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 +401,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 +433,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
@@ -550,5 +606,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 ec4b111..bccb696 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. \fBTcl_VarEval\fR is now deprecated.
.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. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is 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..7cbbded 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
@@ -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..7f8c8a4 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 (e.g.,
+\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\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..89f2b88
--- /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 (e.g.,
+\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\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..d0dbb2f
--- /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 ptrdiff_t 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..1c6f619 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,10 +406,10 @@ 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
+return value is TCL_INDEX_NONE and \fBTcl_ReadChars\fR records a POSIX error code that
can be retrieved with \fBTcl_GetErrno\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
@@ -471,14 +471,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 +496,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 +513,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 +641,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..ca26b59 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,11 @@ 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.
.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..bd019db 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 (e.g.,
+\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\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 e50650e..04a4b7f 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 90678c4..6118a2d 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..4d06923 100644
--- a/doc/TclZlib.3
+++ b/doc/TclZlib.3
@@ -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..2005c93 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.
@@ -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..b0c7f64 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_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,12 +21,36 @@ 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, uniLength, dsPtr\fR)
.sp
+char *
+\fBTcl_Char16ToUtfDString\fR(\fIuStr, uniLength, dsPtr\fR)
+.sp
+char *
+\fBTcl_WCharToUtfDString\fR(\fIwStr, uniLength, dsPtr\fR)
+.sp
Tcl_UniChar *
\fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR)
.sp
+unsigned short *
+\fBTcl_UtfToChar16DString\fR(\fIsrc, length, dsPtr\fR)
+.sp
+wchar_t *
+\fBTcl_UtfToWCharDString\fR(\fIsrc, length, dsPtr\fR)
+.sp
+int
+\fBTcl_Char16Len\fR(\fIuniStr\fR)
+.sp
+int
+\fBTcl_WCharLen\fR(\fIuniStr\fR)
+.sp
int
\fBTcl_UniCharLen\fR(\fIuniStr\fR)
.sp
@@ -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
@@ -94,12 +122,21 @@ A null-terminated Unicode string.
A null-terminated Unicode string.
.AP "const Tcl_UniChar" *uniPattern in
A null-terminated Unicode string.
+.AP "const unsigned short" *uStr in
+A null-terminated UTF-16 string.
+.AP "const wchar_t" *wStr in
+A null-terminated wchar_t string.
+.AP "const unsigned short" *utf16s in
+A null-terminated utf-16 string.
+.AP "const unsigned short" *utf16t in
+A null-terminated utf-16 string.
+.AP "const unsigned short" *utf16Pattern in
+A null-terminated utf-16 string.
.AP 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.
+The length of the Unicode string in characters.
.AP "Tcl_DString" *dsPtr in/out
A pointer to a previously initialized \fBTcl_DString\fR.
.AP "unsigned long" numChars in
@@ -113,7 +150,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 +158,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,13 +180,15 @@ 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 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.
@@ -162,6 +204,14 @@ 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.
.PP
+\fBTcl_Char16Len\fR corresponds to \fBstrlen\fR for UTF-16
+characters. It accepts a null-terminated Unicode string and returns
+the number of Unicode characters (not bytes) in that string.
+.PP
+\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for wchar_t
+characters. It accepts a null-terminated Unicode string and returns
+the number of Unicode characters (not bytes) in that string.
+.PP
\fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode
characters. It accepts a null-terminated Unicode string and returns
the number of Unicode characters (not bytes) in that string.
@@ -200,7 +250,7 @@ of \fIlength\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 +258,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 +289,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..70f569b 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
+.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
+.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
.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
.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
.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
\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
\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
\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
\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
.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
.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..1ecef4c 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,595 @@
.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, \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.
.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 +607,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 +628,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..3d18aea 100644
--- a/doc/close.n
+++ b/doc/close.n
@@ -49,16 +49,13 @@ 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
.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.)
.PP
-.VS 8.6
The two-argument form is a
.QW "half-close" :
given a bidirectional channel like a
@@ -80,7 +77,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
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..19969da 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,114 @@ 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\-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 +521,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 +577,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 +641,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 d7fd96b..3cfc29d 100644
--- a/doc/exec.n
+++ b/doc/exec.n
@@ -331,7 +331,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
@@ -345,7 +344,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..d003a30 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,149 @@ 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
+.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 +184,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 +366,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 +402,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 +429,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 +489,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 +510,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..57f9968 100644
--- a/doc/fcopy.n
+++ b/doc/fcopy.n
@@ -26,8 +26,9 @@ network sockets.
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.
+transferred; \fIsize\fR is in bytes if the input channel is in binary mode,
+or if the two channels are using the same encoding and -strict is not specified.
+Otherwise, size is in characters.
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.
diff --git a/doc/file.n b/doc/file.n
index 0ea53f4..bb6a7d3 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -180,6 +180,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 +269,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 ...?
.
@@ -393,19 +411,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 +455,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 +501,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..335d8c7 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.
@@ -174,3 +175,7 @@ file(n), glob(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/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..8a61ba9 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).
+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
-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.
-.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,167 @@ 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 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 +537,160 @@ 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 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 +699,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 +721,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 +741,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 +767,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 +777,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..70e0bf3
--- /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 0 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}
+c d e f g
+% ledit lst -1 -1 a b
+a b c d e f g
+.CE
+.PP
+Append to the list.
+.PP
+.CS
+% ledit lst end+1 end+1 h i
+a b c d e f g h i
+.CE
+.PP
+Delete third and fourth elements.
+.PP
+.CS
+% ledit lst 2 3
+a b e f g h i
+.CE
+.PP
+Replace two elements with three.
+.PP
+.CS
+% ledit lst 2 3 x y z
+a b x y z g h i
+% set lst
+a b x y z g h i
+.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 87f13bd..8aa8af7 100644
--- a/doc/library.n
+++ b/doc/library.n
@@ -299,18 +299,13 @@ These variables are only used in the \fBtcl_endOfWord\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 is "\\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 is "\\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..e06be33
--- /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 acessible 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..8763ea6
--- /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 arbirary 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..df8a8bc
--- /dev/null
+++ b/doc/lseq.n
@@ -0,0 +1,92 @@
+'\"
+'\" 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 ".." or "to" defines an inclusive range. The "count" option is used
+to define a count of the number of elements in the list. The short form with a
+single count value will create a range from 0 to count-1.
+
+The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR,
+can also be a valid expression. the lseq command will evaluate the expression
+and use the numeric result, or return an error as with any invalid argument
+value. A valid expression is a valid [expr] expression, however, the result
+must be numeric; a non-numeric string will result in an error.
+
+.SH EXAMPLES
+.CS
+.\"
+
+ lseq 3
+ \(-> 0 1 2
+
+ lseq 3 0
+ \(-> 3 2 1 0
+
+ lseq 10 .. 1 by -2
+ \(-> 10 8 6 4 2
+
+ set l [lseq 0 -5]
+ \(-> 0 -1 -2 -3 -4 -5
+
+ foreach i [lseq [llength $l]] {
+ puts l($i)=[lindex $l $i]
+ }
+ \(-> l(0)=0
+ l(1)=-1
+ l(2)=-2
+ l(3)=-3
+ l(4)=-4
+ l(5)=-5
+
+ foreach i [lseq [llength $l]-1 0] {
+ puts l($i)=[lindex $l $i]
+ }
+ \(-> l(5)=-5
+ l(4)=-4
+ l(3)=-3
+ l(2)=-2
+ l(1)=-1
+ l(0)=0
+
+ set i 17
+ \(-> 17
+ if {$i in [lseq 0 50]} { # equivalent to: (0 <= $i && $i < 50)
+ puts "Ok"
+ } else {
+ puts "outside :("
+ }
+ \(-> Ok
+
+ set sqrs [lmap i [lseq 1 10] {expr $i*$i}]
+ \(-> 1 4 9 16 25 36 49 64 81 100
+.\"
+.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..c7c8cf6 100644
--- a/doc/open.n
+++ b/doc/open.n
@@ -166,8 +166,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 +250,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 +345,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 +386,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 +429,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 +484,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 +547,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 +568,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..0e23c80 100644
--- a/doc/puts.n
+++ b/doc/puts.n
@@ -96,3 +96,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/refchan.n b/doc/refchan.n
index edc9974..ae900c5 100644
--- a/doc/refchan.n
+++ b/doc/refchan.n
@@ -322,6 +322,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/trace.n b/doc/trace.n
index 5482e59..570b263 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
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/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..3b13cd9
--- /dev/null
+++ b/doc/zipfs.3
@@ -0,0 +1,120 @@
+'\"
+'\" 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, mountpoint, zipname, password\fR)
+.sp
+int
+\fBTclZipfs_MountBuffer\fR(\fIinterp, mountpoint, data, dataLen, 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 "unsigned char" *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\fB/app\fR as a read-only Tcl virtual file
+system. \fIZIPFS_VOLUME\fR is usually \fB//zipfs:\fR on all platforms, but
+\fBzipfs:\fR may also be used on Windows (due to differences in the
+platform's filename parsing).
+.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 (e.g.,
+\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\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 mounts the ZIP archive \fIzipname\fR on the mount point
+given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR.
+Errors during that process are reported in the interpreter \fIinterp\fR. If
+\fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP
+file systems is written into \fIinterp\fR's result as a sequence of mount
+points and ZIP file names. The result of this call is a standard Tcl result
+code.
+.PP
+\fBTclzipfs_MountBuffer\fR mounts the ZIP archive in the buffer pointed to by
+\fIdata\fR on the mount point given in \fImountpoint\fR. The ZIP archive is
+assumed to be not password protected. Errors during that process are reported
+in the interpreter \fIinterp\fR. The \fIcopy\fR argument determines whether
+the buffer is internally copied before mounting or not. The result of this
+call is a standard Tcl result code.
+.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..a75a70b
--- /dev/null
+++ b/doc/zipfs.n
@@ -0,0 +1,256 @@
+'\"
+'\" 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 ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR?
+\fBzipfs root\fR
+\fBzipfs unmount\fR \fImountpoint\fR
+.fi
+'\" The following subcommand is *UNDOCUMENTED*
+'\" \fBzipfs mount_data\fR ?\fImountpoint\fR? ?\fIdata\fR?
+.BE
+.SH DESCRIPTION
+.PP
+The \fBzipfs\fR command (the sole public command provided by the built-in
+package with the same name) provides Tcl with the ability to mount the
+contents of a ZIP archive file as a virtual file system. ZIP archives support
+simple encryption, sufficient to prevent casual inspection of their contents
+but not able to prevent access by even a moderately determined attacker.
+.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
+.
+Recursively lists files including and below the directory \fIdirectoryName\fR.
+The result list consists of relative path names starting from the given
+directory. 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
+Note: 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.
+.RE
+.TP
+\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR?
+.
+Return a list of all files in the mounted zipfs, or just those matching
+\fIpattern\fR (optionally controlled by the option parameters). The order of
+the names in the list is arbitrary.
+.TP
+\fBzipfs mount\fR ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR?
+.
+The \fBzipfs mount\fR command mounts a ZIP archive file 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.
+.RS
+.PP
+With no \fIzipfile\fR, returns the zipfile mounted at \fImountpoint\fR. With
+no \fImountpoint\fR, return all zipfile/mount pairs. If \fImountpoint\fR is
+specified as an empty string, mount on file path.
+.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. On Windows, this value is
+.QW \fBzipfs:/\fR .
+On Unix, this value is
+.QW \fB//zipfs:/\fR .
+.TP
+\fBzipfs unmount \fImountpoint\fR
+.
+Unmounts a previously mounted ZIP archive mounted to \fImountpoint\fR.
+.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 $base $zip
+# $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 $zip
+.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 $base $zip $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 4f0ac88..1ac04ef 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..5bda852 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,10 +88,10 @@ 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
+#if TCL_UTF_MAX > 3
#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 */
+#define CHR_MAX 0x10FFFF /* 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 */
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 361bd29..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
@@ -54,7 +54,6 @@ static const struct rerr {
/*
- regerror - the interface to error numbers
*/
-/* ARGSUSED */
size_t /* Actual space needed (including NUL) */
regerror(
int code, /* Error code, or REG_ATOI or REG_ITOA */
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 58b7400..2e5d7b4 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 *lengthPtr)
+ unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *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,65 +196,65 @@ 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 length)
+ 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)
}
@@ -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)
@@ -598,8 +600,8 @@ declare 166 {
# generic interface, so we include it here for compatibility reasons.
declare 167 unix {
- int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
- int checkUsage, ClientData *filePtr)
+ int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID,
+ int forWriting, int checkUsage, void **filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
@@ -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,25 +1247,25 @@ 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)
}
@@ -1274,29 +1274,29 @@ declare 358 {
}
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_Size 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, Tcl_Obj *const objv[],
- int flags)
+ 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,
@@ -2272,7 +2272,8 @@ declare 618 {
int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush)
}
declare 619 {
- int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count)
+ int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data,
+ Tcl_Size count)
}
declare 620 {
int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle)
@@ -2326,15 +2327,244 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
-# (unsupported in Tcl 8.6)
+# 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 *mountPoint,
+ const char *zipname, 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 char *mountPoint,
+ unsigned char *data, size_t datalen, 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 *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int *numBytesPtr)
+}
+declare 650 {
+ unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ void *numBytesPtr)
+}
+
+# TIP #481
declare 651 {
- char *TclGetStringFromObj_(Tcl_Obj *objPtr, void *lengthPtr)
+ char *TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr)
}
declare 652 {
- unsigned short *TclGetUnicodeFromObj_(Tcl_Obj *objPtr, void *lengthPtr)
+ unsigned short *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr)
}
+# Only available in Tcl 8.x, NULL in Tcl 9.0
declare 653 {
- unsigned char *TclGetByteArrayFromObj_(Tcl_Obj *objPtr, void *numBytesPtr)
+ unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, void *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 #616
+declare 661 {
+ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ void *objcPtr, Tcl_Obj ***objvPtr)
+}
+declare 662 {
+ int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ void *lengthPtr)
+}
+declare 663 {
+ int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr)
+}
+declare 664 {
+ int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
+ const char ***argvPtr)
+}
+declare 665 {
+ void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr)
+}
+declare 666 {
+ Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr)
+}
+declare 667 {
+ int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
+ void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
+}
+
+# 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)
+}
+declare 676 {
+ Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_ObjCmdProc2 *proc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 677 {
+ Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc2 *objProc2, void *clientData,
+ Tcl_CmdObjTraceDeleteProc *delProc)
+}
+declare 678 {
+ Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc,
+ Tcl_ObjCmdProc2 *nreProc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 679 {
+ int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
+ void *clientData, ptrdiff_t objc, Tcl_Obj *const objv[])
+}
+
+# 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, ptrdiff_t 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 ----- #
@@ -2366,7 +2596,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)
}
################################
@@ -2380,10 +2610,10 @@ declare 0 macosx {
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)
}
##############################################################################
@@ -2391,13 +2621,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)
}
@@ -2412,6 +2655,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 942ca72..2b6c947 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -38,24 +38,29 @@ 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)
*/
-#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 6
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 13
+#if !defined(TCL_MAJOR_VERSION)
+# define TCL_MAJOR_VERSION 8
+#endif
+#if TCL_MAJOR_VERSION != 8
+# error "This header-file is for Tcl 8 only"
+#endif
+#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.
@@ -85,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.
@@ -97,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
@@ -118,6 +123,7 @@ extern "C" {
*/
#include <stdio.h>
+#include <stddef.h>
/*
*----------------------------------------------------------------------------
@@ -131,7 +137,7 @@ extern "C" {
*/
#include <stdarg.h>
-#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#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)
@@ -143,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
@@ -150,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
@@ -189,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
@@ -252,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
@@ -262,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
/*
@@ -313,6 +300,7 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
+#ifndef TCL_NO_DEPRECATED
#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
@@ -328,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
@@ -355,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__ */
@@ -371,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
/*
@@ -390,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_MAX
+# define TCL_SIZE_MODIFIER ""
+#else
+ typedef ptrdiff_t Tcl_Size;
+# define TCL_SIZE_MAX PTRDIFF_MAX
+# 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;
@@ -505,35 +476,13 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
*/
typedef struct Tcl_Interp
-#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#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;
@@ -567,9 +516,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
/*
@@ -635,19 +584,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;
/*
@@ -685,7 +643,9 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_BREAK 3
#define TCL_CONTINUE 4
+#ifndef TCL_NO_DEPRECATED
#define TCL_RESULT_SIZE 200
+#endif
/*
*----------------------------------------------------------------------------
@@ -701,6 +661,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;
@@ -712,6 +673,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
@@ -726,64 +691,74 @@ 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);
+typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp,
+ ptrdiff_t level, const char *command, Tcl_Command commandInfo, ptrdiff_t objc,
+ struct Tcl_Obj *const *objv);
+typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr);
-typedef int (Tcl_EncodingConvertProc) (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);
+typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp,
+ ptrdiff_t objc, struct Tcl_Obj *const *objv);
+typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp);
+typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags);
typedef void (Tcl_PanicProc) (const char *format, ...);
-typedef void (Tcl_TcpAcceptProc) (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
@@ -808,6 +783,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.
@@ -816,7 +815,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
@@ -828,45 +827,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);
/*
*----------------------------------------------------------------------------
@@ -875,6 +844,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;
@@ -882,8 +852,9 @@ typedef struct Tcl_SavedResult {
char *appendResult;
int appendAvl;
int appendUsed;
- char resultSpace[TCL_RESULT_SIZE+1];
+ char resultSpace[200+1];
} Tcl_SavedResult;
+#endif
/*
*----------------------------------------------------------------------------
@@ -899,7 +870,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
@@ -936,14 +907,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;
@@ -967,23 +938,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;
/*
@@ -997,9 +970,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
@@ -1008,12 +981,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
@@ -1025,7 +1000,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.
@@ -1041,13 +1030,29 @@ 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.
* WARNING: these bit choices must not conflict with the bit choices for
@@ -1099,7 +1104,11 @@ 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
@@ -1134,9 +1143,9 @@ typedef struct Tcl_DString {
* give the flag)
*/
-#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#ifndef TCL_NO_DEPRECATED
# define TCL_PARSE_PART1 0x400
-#endif /* !TCL_NO_DEPRECATED */
+#endif
/*
* Types for linked variables:
@@ -1152,40 +1161,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.
*/
@@ -1194,16 +1206,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. */
@@ -1291,16 +1297,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
@@ -1321,7 +1332,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. */
@@ -1362,8 +1373,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;
@@ -1395,11 +1406,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;
/*
@@ -1428,8 +1440,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);
/*
*----------------------------------------------------------------------------
@@ -1465,16 +1477,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)
/*
@@ -1488,41 +1506,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:
@@ -1543,7 +1561,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. */
@@ -1703,13 +1721,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;
@@ -1739,7 +1757,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;
@@ -1901,8 +1919,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
@@ -2016,28 +2034,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.
@@ -2056,10 +2080,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
@@ -2087,13 +2110,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;
/*
@@ -2120,10 +2143,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
@@ -2138,6 +2161,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
@@ -2145,6 +2174,17 @@ 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_TCL8 0x01000000
+#define TCL_ENCODING_PROFILE_STRICT 0x02000000
+#define TCL_ENCODING_PROFILE_REPLACE 0x03000000
+#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8
/*
* The following definitions are the error codes returned by the conversion
@@ -2181,16 +2221,19 @@ 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
- * (or perhaps 1 if we want to support a non-unicode enabled core). 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
+ * (or perhaps 1 if we want to support a non-unicode enabled core). If 3,
+ * then Tcl_UniChar must be 2-bytes in size (UTF-16) (the default). If > 3,
+ * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UTF-16 mode
+ * is the default and recommended mode.
*/
#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
/*
@@ -2198,15 +2241,13 @@ typedef struct Tcl_EncodingType {
* reflected in regcustom.h.
*/
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
/*
- * 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;
+typedef int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
@@ -2238,18 +2279,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
/*
*----------------------------------------------------------------------------
@@ -2268,7 +2318,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;
/*
@@ -2291,9 +2341,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);
/*
@@ -2360,10 +2410,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);
/*
@@ -2372,7 +2437,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
@@ -2382,17 +2451,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
/*
@@ -2401,12 +2484,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
/*
*----------------------------------------------------------------------------
@@ -2477,19 +2570,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); \
@@ -2497,6 +2595,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
TclFreeObj(_objPtr); \
} \
} while(0)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
@@ -2513,22 +2612,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__)
@@ -2546,7 +2639,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) \
@@ -2567,27 +2660,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:
*/
@@ -2606,7 +2678,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# define panic Tcl_Panic
#endif
# define panicVA Tcl_PanicVA
-#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------------
@@ -2617,6 +2688,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 5eaa2eb..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 by 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;
@@ -275,7 +275,7 @@ TclpAlloc(
if (numBytes >= MAXMALLOC - OVERHEAD) {
if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) {
bigBlockPtr = (struct block *) TclpSysAlloc(
- (sizeof(struct block) + OVERHEAD + numBytes), 0);
+ sizeof(struct block) + OVERHEAD + numBytes, 0);
}
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
@@ -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,15 +739,17 @@ 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 */
+#else
+TCL_MAC_EMPTY_FILE(generic_tclAlloc_c)
#endif /* !TCL_THREADS */
/*
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
new file mode 100755
index 0000000..632943a
--- /dev/null
+++ b/generic/tclArithSeries.c
@@ -0,0 +1,1004 @@
+/*
+ * 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 "tclArithSeries.h"
+#include <assert.h>
+
+/* -------------------------- ArithSeries object ---------------------------- */
+
+
+#define ArithSeriesRepPtr(arithSeriesObjPtr) \
+ (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1)
+
+#define ArithSeriesIndexM(arithSeriesRepPtr, index) \
+ ((arithSeriesRepPtr)->isDouble ? \
+ (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \
+ : \
+ ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step)))
+
+#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \
+ (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr);
+static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfArithSeries (Tcl_Obj *arithSeriesObj);
+static Tcl_Obj *ArithSeriesObjStep(Tcl_Obj *arithSeriesPtr);
+
+/*
+ * 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.
+ */
+
+const Tcl_ObjType tclArithSeriesType = {
+ "arithseries", /* name */
+ FreeArithSeriesInternalRep, /* freeIntRepProc */
+ DupArithSeriesInternalRep, /* dupIntRepProc */
+ UpdateStringOfArithSeries, /* updateStringProc */
+ SetArithSeriesFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
+ArithSeriesLen(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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = (len>=0 ? len : ArithSeriesLen(start, end, step));
+ Tcl_Obj *arithSeriesObj;
+ ArithSeries *arithSeriesRepPtr;
+
+ 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 = (len>=0 ? len : ArithSeriesLen(start, end, step));
+ Tcl_Obj *arithSeriesObj;
+ ArithSeriesDbl *arithSeriesRepPtr;
+
+ 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;
+ 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, len;
+
+ 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) {
+ *arithSeriesObj = Tcl_NewObj();
+ 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) {
+ len = (dend - dstart + dstep)/dstep;
+ } else {
+ len = (end - start + step)/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", NULL);
+ return TCL_ERROR;
+ }
+
+ if (arithSeriesObj) {
+ *arithSeriesObj = (useDoubles)
+ ? NewArithSeriesDbl(dstart, dend, dstep, len)
+ : NewArithSeriesInt(start, end, step, len);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = ArithSeriesRepPtr(arithSeriesObj);
+ if (arithSeriesRepPtr->isDouble) {
+ TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
+ } else {
+ TclNewIntObj(stepObj, arithSeriesRepPtr->step);
+ }
+ return stepObj;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_Interp *interp,
+ Tcl_Obj *arithSeriesObj,
+ Tcl_Size index)
+{
+ ArithSeries *arithSeriesRepPtr;
+
+ if (arithSeriesObj->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj);
+ if (index < 0 || index >= arithSeriesRepPtr->len) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("index %d is out of bounds 0 to %"
+ "d", index, (arithSeriesRepPtr->len-1)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ /* List[i] = Start + (Step * index) */
+ if (arithSeriesRepPtr->isDouble) {
+ return Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ } else {
+ return Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjLength
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesInternalRep --
+ *
+ * Deallocate the storage associated with an arithseries object's
+ * internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees arithSeriesObj's ArithSeries* internal representation and
+ * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries *) arithSeriesObj->internalRep.twoPtrValue.ptr1;
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i;
+ Tcl_Obj**elmts = arithSeriesRepPtr->elements;
+ for(i=0; i<arithSeriesRepPtr->len; i++) {
+ if (elmts[i]) {
+ Tcl_DecrRefCount(elmts[i]);
+ }
+ }
+ ckfree((char *) arithSeriesRepPtr->elements);
+ }
+ ckfree((char *) arithSeriesRepPtr);
+ arithSeriesObj->internalRep.twoPtrValue.ptr1 = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ ArithSeries *copyArithSeriesRepPtr;
+
+ /*
+ * Allocate a new ArithSeries structure. */
+
+ copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries));
+ *copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
+ copyArithSeriesRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ copyPtr->typePtr = &tclArithSeriesType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1;
+ char *elem, *p;
+ Tcl_Obj *elemObj;
+ Tcl_WideInt i;
+ Tcl_WideInt length = 0;
+ int slen;
+
+ /*
+ * Pass 1: estimate space.
+ */
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i);
+ elem = TclGetStringFromObj(elemObj, &slen);
+ Tcl_DecrRefCount(elemObj);
+ slen += 1; /* + 1 is for the space or the nul-term */
+ length += slen;
+ }
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesObj, NULL, length);
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i);
+ elem = TclGetStringFromObj(elemObj, &slen);
+ strcpy(p, elem);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(elemObj);
+ }
+ if (length > 0) arithSeriesObj->bytes[length-1] = '\0';
+ arithSeriesObj->length = length-1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjCopy --
+ *
+ * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C
+ * level a counterpart of the [lrange $list 0 end] command, while using
+ * internals details to be as efficient as possible.
+ *
+ * Results:
+ *
+ * Normally returns a pointer to a new Tcl_Obj, that contains the same
+ * arithSeries value as *arithSeriesObj does. The returned Tcl_Obj has a
+ * refCount of zero. If *arithSeriesObj does not hold an arithSeries,
+ * NULL is returned, and if interp is non-NULL, an error message is
+ * recorded there.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjCopy(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *arithSeriesObj) /* List object for which an element array is
+ * to be returned. */
+{
+ Tcl_Obj *copyPtr;
+ ArithSeries *arithSeriesRepPtr;
+
+ ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr);
+ if (NULL == arithSeriesRepPtr) {
+ if (SetArithSeriesFromAny(interp, arithSeriesObj) != TCL_OK) {
+ /* We know this is going to panic, but it's the message we want */
+ return NULL;
+ }
+ }
+
+ TclNewObj(copyPtr);
+ TclInvalidateStringRep(copyPtr);
+ DupArithSeriesInternalRep(arithSeriesObj, copyPtr);
+ return copyPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+
+ ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr);
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (fromIdx > toIdx) {
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+
+ 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*)arithSeriesObj;
+ 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->len = (end-start+step)/step;
+ 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 = (end-start+step)/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;
+
+ ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr);
+ 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", 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", 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;
+
+ ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr);
+
+ 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;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
new file mode 100644
index 0000000..947d437
--- /dev/null
+++ b/generic/tclArithSeries.h
@@ -0,0 +1,58 @@
+/*
+ * tclArithSeries.h --
+ *
+ * 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.
+ */
+
+/*
+ * 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;
+} ArithSeriesDbl;
+
+
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
+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);
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index e69348c..ab5cd7a 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;
@@ -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;
@@ -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) {
@@ -1987,6 +1997,9 @@ CreateMirrorJumpTable(
}
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Allocate the jumptable.
@@ -2002,15 +2015,15 @@ 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])));
+ TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
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;
@@ -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), 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,
@@ -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.
@@ -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);
@@ -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 da8870d..4159cc4 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 by Scriptics Corporation.
- * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
- * Copyright (c) 2006-2008 by 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 */
+
+
#define INTERP_STACK_INITIAL_SIZE 2000
#define CORO_STACK_INITIAL_SIZE 200
@@ -46,7 +86,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;
/*
@@ -65,13 +105,24 @@ 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 */
+ int length; /* Length of the above error message. */
+ void *clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
-TCL_DECLARE_MUTEX(cancelLock)
+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
@@ -94,15 +145,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 void DeleteInterpProc(Tcl_Interp *interp);
-static void DeleteOpCmdClientData(ClientData clientData);
+static void DeleteOpCmdClientData(void *clientData);
#ifdef USE_DTRACE
static Tcl_ObjCmdProc DTraceObjCmd;
static Tcl_NRPostProc DTraceCmdReturn;
@@ -114,24 +166,34 @@ 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);
@@ -156,9 +218,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;
@@ -167,8 +233,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)
@@ -193,6 +259,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:
*/
@@ -204,12 +288,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},
@@ -217,22 +303,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},
@@ -286,9 +377,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},
@@ -296,6 +385,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.
*/
@@ -303,37 +455,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 }
};
@@ -400,6 +560,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}
};
@@ -429,11 +597,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) {
+ int 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, 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, 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, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, 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, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", 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", NULL);
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ Tcl_AppendResult(interp, (char *)clientData, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
@@ -471,7 +748,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
@@ -489,8 +766,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
@@ -505,6 +782,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
@@ -514,7 +805,11 @@ 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;
TclNewObj(iPtr->objResultPtr);
@@ -574,9 +869,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;
@@ -586,15 +883,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;
@@ -606,10 +904,11 @@ Tcl_CreateInterp(void)
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
- TclNewObj(iPtr->emptyObjPtr);
- /* Another empty object. */
+ 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 */
@@ -742,7 +1041,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;
@@ -812,6 +1111,7 @@ Tcl_CreateInterp(void)
TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
+ TclInitProcessCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -852,14 +1152,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) {
@@ -889,7 +1185,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);
}
@@ -951,24 +1247,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
@@ -982,16 +1280,21 @@ 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", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
/*
@@ -1001,6 +1304,9 @@ Tcl_CreateInterp(void)
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
+ }
+ if (TclZipfs_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
}
#endif
@@ -1011,7 +1317,7 @@ Tcl_CreateInterp(void)
static void
DeleteOpCmdClientData(
- ClientData clientData)
+ void *clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
@@ -1019,6 +1325,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 --
@@ -1039,6 +1410,7 @@ TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
+ const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1048,12 +1420,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_GetString(Tcl_GetObjResult(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_GetString(Tcl_GetObjResult(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", NULL);
+ return TCL_ERROR;
+}
+
+/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
@@ -1079,7 +1522,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;
@@ -1127,7 +1570,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;
@@ -1175,7 +1618,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;
@@ -1257,7 +1700,7 @@ Tcl_DeleteAssocData(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetAssocData(
Tcl_Interp *interp, /* Interpreter associated with. */
const char *name, /* Name of association. */
@@ -1425,7 +1868,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);
@@ -1491,28 +1934,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;
}
/*
@@ -1533,8 +1976,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);
@@ -1556,10 +2001,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);
@@ -1626,7 +2073,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);
}
@@ -1657,7 +2104,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
- ckfree((char *) iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -2057,7 +2504,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. */
@@ -2245,6 +2692,66 @@ Tcl_CreateCommand(
*----------------------------------------------------------------------
*/
+typedef struct {
+ Tcl_ObjCmdProc2 *proc;
+ void *clientData; /* Arbitrary value to pass to proc function. */
+ Tcl_CmdDeleteProc *deleteProc;
+ void *deleteData; /* Arbitrary value to pass to deleteProc function. */
+ Tcl_ObjCmdProc2 *nreProc;
+} CmdWrapperInfo;
+
+
+static int cmdWrapperProc(void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const *objv)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ if (objc < 0) {
+ objc = -1;
+ }
+ return info->proc(info->clientData, interp, objc, objv);
+}
+
+static void cmdWrapperDeleteProc(void *clientData) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+
+ clientData = info->deleteData;
+ Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
+ ckfree(info);
+ if (deleteProc != NULL) {
+ deleteProc(clientData);
+ }
+}
+
+Tcl_Command
+Tcl_CreateObjCommand2(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name. */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->clientData = clientData;
+ info->deleteProc = deleteProc;
+ info->deleteData = clientData;
+
+ return Tcl_CreateObjCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_CreateObjCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -2255,7 +2762,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
@@ -2305,7 +2812,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
@@ -2448,7 +2955,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;
}
@@ -2488,7 +2998,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. */
@@ -2499,7 +3009,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;
@@ -2536,7 +3046,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. */
@@ -2753,7 +3263,7 @@ TclRenameCommand(
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
- CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
+ CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
@@ -2875,8 +3385,14 @@ Tcl_SetCommandInfoFromToken(
}
cmdPtr->objClientData = infoPtr->objClientData;
}
- cmdPtr->deleteProc = infoPtr->deleteProc;
- cmdPtr->deleteData = infoPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ info->deleteProc = infoPtr->deleteProc;
+ info->deleteData = infoPtr->deleteData;
+ } else {
+ cmdPtr->deleteProc = infoPtr->deleteProc;
+ cmdPtr->deleteData = infoPtr->deleteData;
+ }
return 1;
}
@@ -2953,10 +3469,15 @@ Tcl_GetCommandInfoFromToken(
infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
- infoPtr->deleteProc = cmdPtr->deleteProc;
- infoPtr->deleteData = cmdPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ infoPtr->deleteProc = info->deleteProc;
+ infoPtr->deleteData = info->deleteData;
+ } else {
+ infoPtr->deleteProc = cmdPtr->deleteProc;
+ infoPtr->deleteData = cmdPtr->deleteData;
+ }
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
-
return 1;
}
@@ -2979,7 +3500,7 @@ 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
* not have been deleted. */
@@ -3038,7 +3559,7 @@ 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);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
@@ -3120,13 +3641,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
@@ -3135,7 +3649,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
@@ -3148,6 +3662,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;
}
@@ -3159,17 +3681,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);
/*
@@ -3324,7 +3847,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
@@ -3423,8 +3946,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;
@@ -3531,6 +4054,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3542,7 +4066,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;
@@ -3583,7 +4107,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 */
@@ -3611,13 +4135,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) {
@@ -3628,7 +4157,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;
}
@@ -3696,9 +4225,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);
}
@@ -3725,7 +4254,7 @@ OldMathFuncProc(
static void
OldMathFuncDeleteProc(
- ClientData clientData)
+ void *clientData)
{
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
@@ -3764,7 +4293,7 @@ Tcl_GetMathFuncInfo(
int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Tcl_Obj *cmdNameObj;
Command *cmdPtr;
@@ -3864,6 +4393,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -3926,7 +4456,7 @@ TclInterpReady(
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
+ if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
@@ -4048,7 +4578,7 @@ Tcl_Canceled(
*/
if (iPtr->asyncCancelMsg != NULL) {
- message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
@@ -4105,7 +4635,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
@@ -4128,7 +4658,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.
@@ -4147,7 +4677,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. */
@@ -4264,9 +4794,9 @@ 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]);
@@ -4424,12 +4954,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;
@@ -4475,7 +5005,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
@@ -4487,9 +5019,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.
@@ -4508,11 +5042,12 @@ TclNRRunCallbacks(
static int
NRCommand(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
iPtr->numLevels--;
@@ -4521,7 +5056,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 ??
@@ -4608,7 +5146,7 @@ TEOV_SwitchVarFrame(
static int
TEOV_RestoreVarFrame(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4618,7 +5156,7 @@ TEOV_RestoreVarFrame(
static int
TEOV_Exception(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4647,7 +5185,7 @@ TEOV_Exception(
static int
TEOV_Error(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4666,7 +5204,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);
}
@@ -4715,7 +5253,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);
@@ -4773,7 +5311,7 @@ TEOV_NotFound(
static int
TEOV_NotFoundCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4810,9 +5348,9 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
- int length, traceCode = TCL_OK;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ int traceCode = TCL_OK;
+ const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
@@ -4853,7 +5391,7 @@ TEOV_RunEnterTraces(
static int
TEOV_RunLeaveTraces(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4864,9 +5402,9 @@ TEOV_RunLeaveTraces(
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
int length;
- const char *command = Tcl_GetStringFromObj(commandPtr, &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);
@@ -4953,6 +5491,7 @@ Tcl_EvalTokensStandard(
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -5000,6 +5539,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5073,12 +5613,13 @@ TclEvalEx(
Tcl_Obj **objv, **objvSpace;
int *expand, *lines, *lineSpace;
Tcl_Token *tokenPtr;
- int commandLength, bytesLeft, expandRequested, code = TCL_OK;
+ int bytesLeft, expandRequested, code = TCL_OK;
+ int 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_HASH_TYPE i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
@@ -5270,7 +5811,7 @@ TclEvalEx(
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
int numElements;
- code = TclListObjLength(interp, objv[objectsUsed],
+ code = TclListObjLengthM(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
@@ -5322,7 +5863,7 @@ TclEvalEx(
int numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
- TclListObjGetElements(NULL, temp, &numElements,
+ TclListObjGetElementsM(NULL, temp, &numElements,
&elements);
objectsUsed += numElements;
while (numElements--) {
@@ -5683,7 +6224,7 @@ TclArgumentRelease(
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;
@@ -5735,7 +6276,7 @@ TclArgumentBCEnter(
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
@@ -5841,7 +6382,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) {
@@ -5897,7 +6438,7 @@ TclArgumentGet(
* up by the caller. It knows better than us.
*/
- if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
+ if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) {
return;
}
@@ -5906,7 +6447,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);
@@ -5920,7 +6461,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);
@@ -5955,6 +6496,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
@@ -5962,7 +6504,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
@@ -6007,6 +6549,7 @@ Tcl_GlobalEvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6160,7 +6703,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);
}
@@ -6228,7 +6771,7 @@ TclNREvalObjEx(
Tcl_IncrRefCount(objPtr);
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
@@ -6240,7 +6783,7 @@ TclNREvalObjEx(
static int
TEOEx_ByteCodeCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6259,7 +6802,7 @@ TEOEx_ByteCodeCallback(
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
@@ -6286,7 +6829,7 @@ TEOEx_ByteCodeCallback(
static int
TEOEx_ListCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6493,14 +7036,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;
}
@@ -6516,8 +7059,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;
@@ -6540,14 +7082,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:
@@ -6678,7 +7220,7 @@ TclObjInvoke(
int
TclNRInvoke(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6721,7 +7263,7 @@ TclNRInvoke(
static int
NRPostInvoke(
- ClientData clientData[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -6764,7 +7306,7 @@ 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);
@@ -6838,6 +7380,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
@@ -6847,6 +7390,7 @@ Tcl_AddErrorInfo(
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6887,7 +7431,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
@@ -6897,9 +7442,9 @@ Tcl_AddObjErrorInfo(
*/
iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
- } else {
+ } else
+#endif /* !defined(TCL_NO_DEPRECATED) */
iPtr->errorInfo = iPtr->objResultPtr;
- }
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", NULL);
@@ -6921,7 +7466,7 @@ Tcl_AddObjErrorInfo(
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
@@ -6930,12 +7475,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
@@ -6962,7 +7507,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;
}
@@ -6984,6 +7529,7 @@ Tcl_VarEvalVA(
*
*----------------------------------------------------------------------
*/
+
int
Tcl_VarEval(
Tcl_Interp *interp,
@@ -7018,6 +7564,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
@@ -7031,10 +7578,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 */
/*
*----------------------------------------------------------------------
@@ -7156,7 +7704,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. */
@@ -7172,9 +7720,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) {
@@ -7192,7 +7744,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. */
@@ -7208,9 +7760,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) {
@@ -7228,12 +7784,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;
@@ -7254,7 +7810,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;
}
@@ -7282,7 +7838,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;
}
@@ -7310,10 +7866,16 @@ 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;
@@ -7328,7 +7890,7 @@ ExprIsqrtFunc(
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. */
@@ -7344,21 +7906,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 {
@@ -7369,7 +7942,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
@@ -7387,10 +7960,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) {
@@ -7406,12 +7983,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
*/
@@ -7429,7 +8006,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
@@ -7447,10 +8024,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) {
@@ -7458,10 +8039,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) {
@@ -7473,13 +8058,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;
@@ -7488,32 +8073,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])) {
+ int 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;
}
@@ -7537,27 +8135,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:
@@ -7582,7 +8166,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. */
@@ -7603,7 +8187,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. */
@@ -7617,7 +8201,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;
}
@@ -7629,8 +8213,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. */
@@ -7638,31 +8222,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) {
@@ -7671,6 +8243,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;
}
}
@@ -7692,73 +8269,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. */
@@ -7851,14 +8446,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) {
@@ -7866,13 +8461,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) {
@@ -7882,27 +8477,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;
}
}
@@ -7926,14 +8525,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.
@@ -7944,20 +8543,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;
}
/*
@@ -7966,8 +8553,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;
}
@@ -7978,7 +8564,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;
}
/*
@@ -8005,7 +8980,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) {
@@ -8040,8 +9015,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. */
{
@@ -8143,7 +9118,7 @@ TclDTraceInfo(
static int
DTraceCmdReturn(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8188,7 +9163,7 @@ int
Tcl_NRCallObjProc(
Tcl_Interp *interp,
Tcl_ObjCmdProc *objProc,
- ClientData clientData,
+ void *clientData,
int objc,
Tcl_Obj *const objv[])
{
@@ -8199,6 +9174,42 @@ Tcl_NRCallObjProc(
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
+int wrapperNRObjProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ clientData = info->clientData;
+ Tcl_ObjCmdProc2 *proc = info->proc;
+ ckfree(info);
+ return proc(clientData, interp, objc, objv);
+}
+
+int
+Tcl_NRCallObjProc2(
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc,
+ void *clientData,
+ ptrdiff_t objc,
+ Tcl_Obj *const objv[])
+{
+ if ((size_t)objc > INT_MAX) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?args?");
+ return TCL_ERROR;
+ }
+
+ NRE_callback *rootPtr = TOP_CB(interp);
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->clientData = clientData;
+ info->proc = objProc;
+
+ TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info,
+ INT2PTR(objc), objv);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -8227,6 +9238,50 @@ Tcl_NRCallObjProc(
*----------------------------------------------------------------------
*/
+static int cmdWrapperNreProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ if (objc < 0) {
+ objc = -1;
+ }
+ return info->nreProc(info->clientData, interp, objc, objv);
+}
+
+Tcl_Command
+Tcl_NRCreateCommand2(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name, provides direct access for direct
+ * calls. */
+ Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with
+ * name, provides NR implementation */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc)
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->clientData = clientData;
+ info->nreProc = nreProc;
+ info->deleteProc = deleteProc;
+ info->deleteData = clientData;
+ return Tcl_NRCreateCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ (nreProc ? cmdWrapperNreProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_NRCreateCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -8240,14 +9295,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;
@@ -8260,11 +9316,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;
@@ -8422,7 +9479,7 @@ TclSetTailcall(
int
TclNRTailcallObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8487,7 +9544,7 @@ TclNRTailcallObjCmd(
int
TclNRTailcallEval(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8497,7 +9554,7 @@ TclNRTailcallEval(
int objc;
Tcl_Obj **objv;
- TclListObjGetElements(interp, listPtr, &objc, &objv);
+ TclListObjGetElementsM(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
@@ -8526,8 +9583,8 @@ TclNRTailcallEval(
int
TclNRReleaseValues(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
@@ -8547,10 +9604,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?!");
@@ -8584,7 +9641,7 @@ Tcl_NRAddCallback(
int
TclNRYieldObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8615,7 +9672,7 @@ TclNRYieldObjCmd(
int
TclNRYieldToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8659,19 +9716,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
@@ -8694,7 +9753,7 @@ RewindCoroutine(
static void
DeleteCoroutine(
- ClientData clientData)
+ void *clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
@@ -8707,7 +9766,7 @@ DeleteCoroutine(
static int
NRCoroutineCallerCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8738,7 +9797,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
@@ -8753,7 +9812,7 @@ NRCoroutineCallerCallback(
static int
NRCoroutineExitCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8818,14 +9877,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, unused;
- int *stackLevel = &unused;
if (!corPtr->stackLevel) {
/*
@@ -8842,8 +9898,8 @@ TclNRCoroutineActivateCallback(
* the interp's environment to make it suitable to run this coroutine.
*/
- corPtr->stackLevel = stackLevel;
- numLevels = corPtr->auxNumLevels;
+ corPtr->stackLevel = &corPtr;
+ int numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
SAVE_CONTEXT(corPtr->caller);
@@ -8856,7 +9912,23 @@ TclNRCoroutineActivateCallback(
* Coroutine is active: yield
*/
- if (corPtr->stackLevel != stackLevel) {
+ if (corPtr->stackLevel != &corPtr) {
+ 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));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
@@ -8864,6 +9936,7 @@ TclNRCoroutineActivateCallback(
return TCL_ERROR;
}
+ void *type = data[1];
if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
} else if (type == CORO_ACTIVATE_YIELDM) {
@@ -8872,9 +9945,10 @@ TclNRCoroutineActivateCallback(
Tcl_Panic("Yield received an option which is not implemented");
}
+ corPtr->yieldPtr = NULL;
corPtr->stackLevel = NULL;
- numLevels = iPtr->numLevels;
+ int numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
@@ -8897,9 +9971,9 @@ TclNRCoroutineActivateCallback(
static int
TclNREvalList(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
int objc;
Tcl_Obj **objv;
@@ -8909,7 +9983,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);
}
@@ -8925,7 +9999,7 @@ TclNREvalList(
static int
CoroTypeObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8985,27 +10059,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, -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objPtr), 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", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", 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) {
@@ -9013,16 +10151,202 @@ 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",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", 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;
+ int 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];
+ int nargs = PTR2INT(data[2]);
+ void *isProbe = data[3];
+ int 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", -1));
+ } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yieldto", -1));
+ } else {
+ /*
+ * I don't think this is reachable...
+ */
+
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj(nargs));
+ }
+ 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];
+ int 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;
+ int 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));
@@ -9045,7 +10369,7 @@ NRCoroInjectObjCmd(
int
TclNRInterpCoroutine(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9055,7 +10379,7 @@ TclNRInterpCoroutine(
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
- Tcl_GetString(objv[0])));
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
@@ -9076,7 +10400,7 @@ 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));
@@ -9109,7 +10433,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. */
@@ -9197,6 +10521,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
@@ -9242,7 +10567,7 @@ TclNRCoroutineObjCmd(
int
TclInfoCoroutineCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -9254,7 +10579,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..183d545 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,36 +371,131 @@ 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);
+
+ Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBytesFromObj/TclGetBytesFromObj --
+ *
+ * Attempt to extract the value from objPtr in the representation
+ * of a byte sequence. On success return the extracted byte sequence.
+ * On failure, return NULL and record error message and code in
+ * interp (if not NULL).
+ *
+ * Results:
+ * NULL or pointer to array of bytes representing the ByteArray object.
+ * Writes number of bytes in array to *numBytesPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+unsigned char *
+TclGetBytesFromObj(
+ 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);
+ TclUtfToUCS4(nonbyte, &ucs4);
- if ((bytes != NULL) && (length > 0)) {
- memcpy(byteArrayPtr->bytes, bytes, length);
+ 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", NULL);
+ }
+ return NULL;
+ }
+ }
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *numBytesPtr = baPtr->used;
}
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ return baPtr->bytes;
+}
+#undef Tcl_GetBytesFromObj
+unsigned char *
+Tcl_GetBytesFromObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj *objPtr, /* Value to extract from */
+ void *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);
+ TclUtfToUCS4(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", NULL);
+ }
+ return NULL;
+ }
+ }
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *(ptrdiff_t *)numBytesPtr = baPtr->used;
+ }
+ return baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_GetByteArrayFromObj --
+ * Tcl_GetByteArrayFromObj/TclGetByteArrayFromObj --
*
* Attempt to get the array of bytes from the Tcl object. If the object
* is not already a ByteArray object, an attempt will be made to convert
@@ -348,24 +510,57 @@ Tcl_SetByteArrayObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetByteArrayFromObj
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. */
+ int *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
{
ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr;
+ unsigned char *result = TclGetBytesFromObj(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;
}
+
+unsigned char *
+TclGetByteArrayFromObj(
+ Tcl_Obj *objPtr, /* The ByteArray object. */
+ void *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 (result) {
+ return result;
+ }
+
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ assert(irPtr != NULL);
+
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ /* Make sure we return a value between 0 and UINT_MAX-1, or (ptrdiff_t)-1 */
+ *(ptrdiff_t *)numBytesPtr = ((ptrdiff_t)(unsigned int)(baPtr->used + 1)) - 1;
+ }
+ return baPtr->bytes;
+}
/*
*----------------------------------------------------------------------
@@ -392,27 +587,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 +646,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 (TclHasInternalRep(objPtr, &properByteArrayType)) {
+ return TCL_OK;
+ }
+ if (TclHasInternalRep(objPtr, &tclByteArrayType)) {
+ return TCL_OK;
+ }
- if (objPtr->typePtr != &tclByteArrayType) {
- src = TclGetStringFromObj(objPtr, &length);
- srcEnd = src + length;
+ 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 +715,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 +749,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 +791,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 +800,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 +808,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 +827,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 +867,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 +884,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 +927,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 +943,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 +1001,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 +1125,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 +1138,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 +1411,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 +1477,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 +1510,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 +1528,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 +1553,8 @@ BinaryScanCmd(
}
switch (cmd) {
case 'a':
- case 'A': {
+ case 'A':
+ case 'C': {
unsigned char *src;
if (arg >= objc) {
@@ -1308,10 +1576,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 +1840,7 @@ BinaryScanCmd(
*/
done:
- Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3));
DeleteScanNumberCache(numberCachePtr);
return TCL_OK;
@@ -1579,11 +1855,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 +2128,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 +2148,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 +2163,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 +2183,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 +2198,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 +2216,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 +2246,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 +2268,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 +2284,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 +2301,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 +2413,7 @@ ScanNumber(
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
} else {
Tcl_HashTable *tablePtr = *numberCachePtrPtr;
Tcl_HashEntry *hPtr;
@@ -2142,8 +2424,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 +2443,7 @@ ScanNumber(
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
}
/*
@@ -2194,8 +2477,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 +2591,7 @@ DeleteScanNumberCache(
static int
BinaryEncodeHex(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2351,7 +2635,7 @@ BinaryEncodeHex(
static int
BinaryDecodeHex(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2359,8 +2643,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 +2665,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 = TclGetBytesFromObj(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 +2683,7 @@ BinaryDecodeHex(
}
c = *data++;
- if (!isxdigit((int) c)) {
+ if (!isxdigit(UCHAR(c))) {
if (strict || !TclIsSpaceProc(c)) {
goto badChar;
}
@@ -2429,14 +2716,14 @@ BinaryDecodeHex(
badChar:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid hexadecimal digit \"%c\" at position %d",
- ch, (int) (data - datastart - 1)));
+ "invalid hexadecimal digit \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
return TCL_ERROR;
}
@@ -2472,7 +2759,7 @@ BinaryDecodeHex(
static int
BinaryEncode64(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2510,12 +2797,11 @@ BinaryEncode64(
}
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 *)TclGetBytesFromObj(NULL,
+ objv[i + 1], &wrapcharlen);
+ if (wrapchar == NULL) {
+ purewrap = 0;
+ wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
@@ -2595,7 +2881,7 @@ BinaryEncode64(
static int
BinaryEncodeUu(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2744,7 +3030,7 @@ BinaryEncodeUu(
static int
BinaryDecodeUu(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2752,9 +3038,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 +3061,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 = TclGetBytesFromObj(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);
@@ -2884,13 +3173,13 @@ BinaryDecodeUu(
badUu:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid uuencode character \"%c\" at position %d",
- ch, (int) (data - datastart - 1)));
+ "invalid uuencode character \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
@@ -2914,7 +3203,7 @@ BinaryDecodeUu(
static int
BinaryDecode64(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2923,9 +3212,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 +3235,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 = TclGetBytesFromObj(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,19 +3342,19 @@ 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);
+ TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid base64 character \"%c\" at position %d", ch,
- (int) (data - datastart - 1)));
+ "invalid base64 character \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", 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 d379762..39fb073 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;
}
@@ -488,27 +469,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;
@@ -577,7 +558,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 */
@@ -589,7 +570,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -600,7 +581,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)
@@ -610,7 +591,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -628,7 +609,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);
}
@@ -661,7 +642,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 */
@@ -673,7 +654,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -684,7 +665,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],
@@ -694,7 +675,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -712,7 +693,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);
}
@@ -754,7 +735,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;
}
@@ -819,7 +800,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) {
@@ -957,7 +938,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;
}
@@ -1009,7 +990,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;
}
@@ -1079,7 +1060,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;
@@ -1217,7 +1198,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;
@@ -1233,7 +1214,7 @@ GetYearWeekDay(
*/
if (fields->julianDay < temp.julianDay) {
- if (temp.era == BCE) {
+ if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
@@ -1359,10 +1340,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;
@@ -1430,7 +1411,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;
@@ -1474,7 +1455,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;
@@ -1502,10 +1483,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;
}
@@ -1580,7 +1561,7 @@ IsGregorianLeapYear(
{
int year = fields->year;
- if (fields->era == BCE) {
+ if (fields->isBce) {
year = 1 - year;
}
if (year%4 != 0) {
@@ -1645,7 +1626,7 @@ WeekdayOnOrBefore(
int
ClockGetenvObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1658,28 +1639,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;
}
@@ -1748,7 +1729,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 */
@@ -1762,7 +1743,6 @@ ClockClicksObjCmd(
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
- (void)clientData;
switch (objc) {
case 1:
@@ -1819,21 +1799,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;
}
@@ -1857,12 +1838,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;
@@ -1891,7 +1871,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 */
@@ -1938,7 +1918,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]), NULL);
return TCL_ERROR;
}
switch (optionIndex) {
@@ -2009,20 +1989,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;
}
@@ -2110,7 +2092,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..aa7a9b0 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -4,18 +4,19 @@
* 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>
+#include "tclArithSeries.h"
/*
* The state structure used by [foreach]. Note that the actual structure has
@@ -46,11 +47,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 +62,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 +73,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 +122,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 +151,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 +191,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 +268,7 @@ Tcl_CaseObjCmd(
return TCL_OK;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -287,17 +289,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 +333,7 @@ TclNRCatchObjCmd(
static int
CatchObjCmdCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -369,7 +371,7 @@ CatchObjCmdCallback(
}
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
@@ -392,7 +394,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 +449,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 +483,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 +516,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 +529,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;
}
- Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
+ switch (optIndex) {
+ case PROFILE:
+ if (TclEncodingProfileNameToId(interp,
+ TclGetString(objv[argIndex]),
+ &profile) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case FAILINDEX:
+ failVarObj = objv[argIndex];
+ break;
+ }
+ }
+ /* 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 +650,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. */
@@ -658,36 +660,80 @@ EncodingConvertfromObjCmd(
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
+ 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) && (TCL_MAJOR_VERSION < 9)
+ 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 *) TclGetBytesFromObj(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 +756,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. */
@@ -720,17 +766,14 @@ EncodingConverttoObjCmd(
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
+ 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 +782,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 +854,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. */
@@ -816,7 +898,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 +914,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 +957,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 +994,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 +1043,7 @@ Tcl_ErrorObjCmd(
static int
EvalCmdErrMsg(
- ClientData data[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -946,17 +1056,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 +1125,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 +1139,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 +1172,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 +1209,7 @@ TclNRExprObjCmd(
static int
ExprCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1149,40 +1259,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 +1304,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 +1320,7 @@ BadFileSubcommand(
static int
FileAttrAccessTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1368,9 +1346,14 @@ FileAttrAccessTimeCmd(
#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 +1402,7 @@ FileAttrAccessTimeCmd(
static int
FileAttrModifyTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1451,7 +1434,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 +1481,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 +1521,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 +1561,7 @@ FileAttrStatCmd(
static int
FileAttrTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1608,7 +1599,7 @@ FileAttrTypeCmd(
static int
FileAttrSizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1645,7 +1636,7 @@ FileAttrSizeCmd(
static int
FileAttrIsDirectoryCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1683,7 +1674,7 @@ FileAttrIsDirectoryCmd(
static int
FileAttrIsExecutableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1714,7 +1705,7 @@ FileAttrIsExecutableCmd(
static int
FileAttrIsExistingCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1745,7 +1736,7 @@ FileAttrIsExistingCmd(
static int
FileAttrIsFileCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1783,7 +1774,7 @@ FileAttrIsFileCmd(
static int
FileAttrIsOwnedCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1830,7 +1821,7 @@ FileAttrIsOwnedCmd(
static int
FileAttrIsReadableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1861,7 +1852,7 @@ FileAttrIsReadableCmd(
static int
FileAttrIsWritableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1892,7 +1883,7 @@ FileAttrIsWritableCmd(
static int
PathDirNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1931,7 +1922,7 @@ PathDirNameCmd(
static int
PathExtensionCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1970,7 +1961,7 @@ PathExtensionCmd(
static int
PathRootNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2009,7 +2000,7 @@ PathRootNameCmd(
static int
PathTailCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2048,7 +2039,7 @@ PathTailCmd(
static int
PathFilesystemCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2063,7 +2054,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]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fsInfo);
@@ -2089,7 +2080,7 @@ PathFilesystemCmd(
static int
PathJoinCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2121,7 +2112,7 @@ PathJoinCmd(
static int
PathNativeNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2135,7 +2126,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 +2149,7 @@ PathNativeNameCmd(
static int
PathNormalizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2196,7 +2187,7 @@ PathNormalizeCmd(
static int
PathSplitCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2207,7 +2198,7 @@ PathSplitCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- res = Tcl_FSSplitPath(objv[1], NULL);
+ res = Tcl_FSSplitPath(objv[1], (int *)NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
@@ -2239,7 +2230,7 @@ PathSplitCmd(
static int
PathTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2287,7 +2278,7 @@ PathTypeCmd(
static int
FilesystemSeparatorCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2315,7 +2306,7 @@ FilesystemSeparatorCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
- Tcl_GetString(objv[1]), NULL);
+ TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, separatorObj);
@@ -2342,7 +2333,7 @@ FilesystemSeparatorCmd(
static int
FilesystemVolumesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2448,7 +2439,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 +2459,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) {
+ result = Tcl_NewObj();
+ 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 +2516,23 @@ 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
STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(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 +2624,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 +2665,7 @@ TclNRForObjCmd(
static int
ForSetupCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2662,7 +2684,7 @@ ForSetupCallback(
int
TclNRForIterCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2697,7 +2719,7 @@ TclNRForIterCallback(
static int
ForCondCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2735,7 +2757,7 @@ ForCondCallback(
static int
ForNextCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2760,7 +2782,7 @@ ForNextCallback(
static int
ForPostNextCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2796,17 +2818,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 +2838,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 +2856,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. */
@@ -2897,32 +2919,49 @@ EachloopCmd(
*/
for (i=0 ; i<numLists ; i++) {
+ /* List */
+ /* Variables */
statePtr->vCopyList[i] = TclListObjCopy(interp, 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]);
+ TclListObjLengthM(NULL, statePtr->vCopyList[i],
+ &statePtr->varcList[i]);
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%s varlist is empty",
- (statePtr->resultList != NULL ? "lmap" : "foreach")));
+ "%s varlist is empty",
+ (statePtr->resultList != NULL ? "lmap" : "foreach")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
- (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
- "NEEDVARS", NULL);
+ (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
+ "NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
}
-
- statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (statePtr->aCopyList[i] == NULL) {
- result = TCL_ERROR;
- goto done;
- }
- 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] = TclArithSeriesObjCopy(interp, 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;
+ }
+ TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
-
+ }
+ /* account for variable <> value mismatch */
j = statePtr->argcList[i] / statePtr->varcList[i];
if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
@@ -2965,7 +3004,7 @@ EachloopCmd(
static int
ForeachLoopStep(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -3044,10 +3083,22 @@ ForeachAssignments(
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 +3163,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..383cec4 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,10 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include "tclArithSeries.h"
+#include "tclTomMath.h"
+#include <math.h>
+#include <assert.h>
/*
* During execution of the "lsort" command, structures of the following type
@@ -35,7 +39,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 +51,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 +59,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 +73,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 +97,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 +157,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 +172,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 +205,17 @@ static const EnsembleImplMap defaultInfoMap[] = {
int
Tcl_IfObjCmd(
- 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, TclNRIfObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv);
}
int
TclNRIfObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -386,7 +388,7 @@ IfConditionCallback(
int
Tcl_IncrObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -467,7 +469,7 @@ TclInitInfoCmd(
static int
InfoArgsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -530,15 +532,15 @@ InfoArgsCmd(
static int
InfoBodyCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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");
@@ -563,18 +565,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 +593,7 @@ InfoBodyCmd(
static int
InfoCmdCountCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -613,7 +605,7 @@ InfoCmdCountCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount));
return TCL_OK;
}
@@ -643,7 +635,7 @@ InfoCmdCountCmd(
static int
InfoCommandsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -658,7 +650,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 +912,7 @@ InfoCommandsCmd(
static int
InfoCompleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -957,7 +949,7 @@ InfoCompleteCmd(
static int
InfoDefaultCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -995,7 +987,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 +997,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -1040,7 +1032,7 @@ InfoDefaultCmd(
static int
InfoErrorStackCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1055,7 +1047,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 +1081,7 @@ InfoErrorStackCmd(
int
TclInfoExistsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1134,7 +1126,7 @@ TclInfoExistsCmd(
static int
InfoFrameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1179,7 +1171,7 @@ InfoFrameCmd(
* Just "info frame".
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel));
goto done;
}
@@ -1301,9 +1293,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 +1332,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 +1359,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 +1396,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 +1430,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 +1466,7 @@ TclInfoFrame(
static int
InfoFunctionsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1539,7 +1531,7 @@ InfoFunctionsCmd(
static int
InfoHostnameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1585,7 +1577,7 @@ InfoHostnameCmd(
static int
InfoLevelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1593,7 +1585,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;
}
@@ -1659,7 +1651,7 @@ InfoLevelCmd(
static int
InfoLibraryCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1671,7 +1663,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;
@@ -1706,24 +1698,29 @@ InfoLibraryCmd(
static int
InfoLoadedCmd(
- 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 *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 +1746,7 @@ InfoLoadedCmd(
static int
InfoNameOfExecutableCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1785,7 +1782,7 @@ InfoNameOfExecutableCmd(
static int
InfoPatchLevelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1797,7 +1794,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 +1829,7 @@ InfoPatchLevelCmd(
static int
InfoProcsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1930,7 +1927,7 @@ InfoProcsCmd(
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
- TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ TclGetOriginalCommand((Tcl_Command)cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto procOK;
}
@@ -1938,7 +1935,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 +1966,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 +2016,13 @@ InfoProcsCmd(
static int
InfoScriptCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +2064,7 @@ InfoScriptCmd(
static int
InfoSharedlibCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2104,7 +2102,7 @@ InfoSharedlibCmd(
static int
InfoTclVersionCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2128,6 +2126,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(ClientData),
+ 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", 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 +2196,14 @@ InfoTclVersionCmd(
int
Tcl_JoinObjCmd(
- 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 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 +2215,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 +2318,15 @@ Tcl_JoinObjCmd(
int
Tcl_LassignObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +2338,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 +2369,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 +2401,11 @@ Tcl_LassignObjCmd(
int
Tcl_LindexObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +2459,21 @@ Tcl_LindexObjCmd(
int
Tcl_LinsertObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +2542,7 @@ Tcl_LinsertObjCmd(
int
Tcl_ListObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
@@ -2460,20 +2578,22 @@ Tcl_ListObjCmd(
int
Tcl_LlengthObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +2603,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(ClientData),
+ 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", 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 +2729,20 @@ Tcl_LlengthObjCmd(
int
Tcl_LrangeObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(ClientData),
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,55 +2752,162 @@ 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(ClientData),
+ 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;
+
+ /*
+ * 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 *)Tcl_Alloc((objc - 2) * sizeof(*idxv));
+ for (i = 2; i < objc; i++) {
+ if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
+ &idxv[i - 2]) != TCL_OK) {
+ ckfree(idxv);
+ return TCL_ERROR;
+ }
+ }
- 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);
+ }
+ 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.
+ */
+ (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+ listLen -= num;
+ num = 1;
+ first = idx;
+ }
+ }
+ if (num != 0) {
+ (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+ }
+ ckfree(idxv);
+ Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
@@ -2601,13 +2930,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,12 +2949,12 @@ 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);
return TCL_ERROR;
@@ -2654,10 +2984,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 +3011,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 +3045,14 @@ Tcl_LrepeatObjCmd(
int
Tcl_LreplaceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +3060,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 +3081,9 @@ Tcl_LreplaceObjCmd(
return result;
}
- if (first < 0) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
- }
- if (first > listLen) {
+ } else if (first > listLen) {
first = listLen;
}
@@ -2811,19 +3146,35 @@ Tcl_LreplaceObjCmd(
int
Tcl_LreverseObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +3186,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 +3251,37 @@ Tcl_LreverseObjCmd(
int
Tcl_LsearchObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +3301,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 +3321,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,6 +3385,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
+ startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -3042,25 +3406,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", 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", 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;
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -3070,12 +3457,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 +3472,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,15 +3484,14 @@ 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);
result = TCL_ERROR;
@@ -3127,14 +3513,12 @@ 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;
+ result = TCL_ERROR;
+ goto done;
}
if (bisect && (allMatches || negatedMatch)) {
@@ -3142,7 +3526,8 @@ Tcl_LsearchObjCmd(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (mode == REGEXP) {
@@ -3168,9 +3553,6 @@ Tcl_LsearchObjCmd(
}
if (regexp == NULL) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3181,26 +3563,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",
+ 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", 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 +3630,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-1) {
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 +3668,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 +3681,7 @@ Tcl_LsearchObjCmd(
* 1844789]
*/
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+ TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
@@ -3276,18 +3704,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 +3809,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 +3821,7 @@ Tcl_LsearchObjCmd(
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch (mode) {
@@ -3406,8 +3839,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 +3910,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;
- 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));
}
}
}
@@ -3508,14 +3946,17 @@ Tcl_LsearchObjCmd(
if (returnSubindices) {
int 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) {
/*
@@ -3525,7 +3966,14 @@ Tcl_LsearchObjCmd(
Tcl_SetObjResult(interp, Tcl_NewObj());
} 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 +3982,10 @@ Tcl_LsearchObjCmd(
*/
done:
- if (sortInfo.indexc > 1) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
@@ -3559,7 +4010,7 @@ Tcl_LsearchObjCmd(
int
Tcl_LsetObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -3628,6 +4079,406 @@ Tcl_LsetObjCmd(
/*
*----------------------------------------------------------------------
*
+ * 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(ClientData),
+ 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;
+
+/* range n */
+ case 1:
+ start = zero;
+ elementCount = numValues[0];
+ end = NULL;
+ step = one;
+ break;
+
+/* range n n */
+ case 11:
+ start = numValues[0];
+ end = numValues[1];
+ break;
+
+/* range n n n */
+ case 111:
+ start = numValues[0];
+ end = numValues[1];
+ step = numValues[2];
+ break;
+
+/* range n 'to' n */
+/* range n 'count' n */
+/* range 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;
+
+/* range n 'to' n n */
+/* range 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;
+
+/* range 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;
+
+/* range n 'to' n 'by' n */
+/* range 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_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
@@ -3644,7 +4495,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 +4505,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. */
@@ -3741,7 +4593,7 @@ Tcl_LsortObjCmd(
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,13 +4610,12 @@ 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);
result = TCL_ERROR;
@@ -3804,18 +4655,19 @@ Tcl_LsortObjCmd(
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);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
+ groupSize = wide;
group = 1;
i++;
break;
@@ -3834,7 +4686,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 +4702,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]);
}
}
@@ -3893,8 +4746,13 @@ Tcl_LsortObjCmd(
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;
}
@@ -3994,7 +4852,7 @@ Tcl_LsortObjCmd(
goto done;
}
- for (i=0; i < length; i++){
+ for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
@@ -4077,18 +4935,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 +4958,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 +4969,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 +4999,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(ClientData),
+ 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;
+ int first;
+ int last;
+ int listLen;
+ int 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 = last - first + 1;
+ } 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 +5243,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,
@@ -4310,10 +5289,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);
@@ -4450,8 +5429,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;
@@ -4523,7 +5502,7 @@ SelectObjFromSublist(
int listLen, 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,9 +5515,16 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
- "element %d missing from sublist \"%s\"",
- index, TclGetString(objPtr)));
+ if (index == (int)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);
infoPtr->resultCode = TCL_ERROR;
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 85c059a..cd34364 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.
@@ -82,7 +82,7 @@ const char tclDefaultTrimSet[] =
int
Tcl_PwdObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -122,7 +122,7 @@ Tcl_PwdObjCmd(
int
Tcl_RegexpObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -137,7 +137,7 @@ Tcl_RegexpObjCmd(
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", NULL
};
- enum options {
+ enum regexpoptions {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
@@ -162,7 +162,7 @@ Tcl_RegexpObjCmd(
&index) != TCL_OK) {
goto optionError;
}
- switch ((enum options) index) {
+ switch ((enum regexpoptions) index) {
case REGEXP_ALL:
all = 1;
break;
@@ -195,7 +195,7 @@ Tcl_RegexpObjCmd(
if (++i >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[i], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -256,10 +256,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 +310,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 +336,7 @@ Tcl_RegexpObjCmd(
*/
if (!doinline) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -385,17 +385,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 +458,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 +482,33 @@ Tcl_RegexpObjCmd(
int
Tcl_RegsubObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 start, end, subStart, subEnd, match, command, numParts;
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 +523,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;
@@ -546,7 +550,7 @@ Tcl_RegsubObjCmd(
if (++idx >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[idx], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -577,16 +581,16 @@ Tcl_RegsubObjCmd(
objv += idx;
if (startIndex) {
- int stringLength = Tcl_GetCharLength(objv[1]);
+ int 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 +598,17 @@ Tcl_RegsubObjCmd(
* slightly modified version of the one pair STR_MAP code.
*/
- int slen, nocase;
+ int slen, 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 +619,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 +636,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 +666,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", 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 +699,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 +742,7 @@ Tcl_RegsubObjCmd(
break;
}
if (numMatches == 0) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
/*
@@ -722,7 +750,7 @@ Tcl_RegsubObjCmd(
* specified.
*/
- Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
+ TclAppendUnicodeToObj(resultPtr, wstring, offset);
}
}
numMatches++;
@@ -735,7 +763,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;
+ int 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 +867,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 +881,7 @@ Tcl_RegsubObjCmd(
}
if (wfirstChar != wsrc) {
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ TclAppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar);
}
@@ -777,7 +889,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 +901,7 @@ Tcl_RegsubObjCmd(
}
if (wfirstChar != wsrc) {
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
+ TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
}
if (end == 0) {
@@ -799,7 +911,7 @@ Tcl_RegsubObjCmd(
*/
if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
} else {
@@ -811,7 +923,7 @@ Tcl_RegsubObjCmd(
*/
if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
}
@@ -836,7 +948,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 +960,7 @@ Tcl_RegsubObjCmd(
* holding the number of matches.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches));
}
} else {
/*
@@ -890,7 +1002,7 @@ Tcl_RegsubObjCmd(
int
Tcl_RenameObjCmd(
- ClientData dummy, /* Arbitrary value passed to the command. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -926,7 +1038,7 @@ Tcl_RenameObjCmd(
int
Tcl_ReturnObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -973,25 +1085,28 @@ Tcl_ReturnObjCmd(
int
Tcl_SourceObjCmd(
- 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, TclNRSourceObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv);
}
int
TclNRSourceObjCmd(
- 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 *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 +1124,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,12 +1169,12 @@ TclNRSourceObjCmd(
int
Tcl_SplitObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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;
@@ -1081,10 +1217,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 = TclUtfToUCS4(stringPtr, &ch);
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
@@ -1094,14 +1228,14 @@ Tcl_SplitObjCmd(
Tcl_SetHashValue(hPtr, objPtr);
} else {
- objPtr = Tcl_GetHashValue(hPtr);
+ objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
- char *p;
+ const char *p;
/*
* Handle the special case of splitting on a single character. This is
@@ -1119,7 +1253,7 @@ Tcl_SplitObjCmd(
} else {
const char *element, *p, *splitEnd;
int splitLen;
- Tcl_UniChar splitChar = 0;
+ int splitChar;
/*
* Normal case: split on any of a given set of characters. Discard
@@ -1129,9 +1263,9 @@ Tcl_SplitObjCmd(
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
- len = TclUtfToUniChar(stringPtr, &ch);
+ len = TclUtfToUCS4(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
- splitLen = TclUtfToUniChar(p, &splitChar);
+ splitLen = TclUtfToUCS4(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
@@ -1168,13 +1302,12 @@ Tcl_SplitObjCmd(
static int
StringFirstCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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;
+ int start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1182,82 +1315,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.
- */
+ int size = TclGetCharLength(objv[2]);
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &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 +1346,27 @@ StringFirstCmd(
static int
StringLastCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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;
+ int last = INT_MAX - 1;
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
- */
+ int size = TclGetCharLength(objv[2]);
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &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,7 +1390,7 @@ StringLastCmd(
static int
StringIndexCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1395,13 +1406,17 @@ StringIndexCmd(
* Get the char length to calculate what 'end' means.
*/
- length = Tcl_GetCharLength(objv[1]);
+ length = TclGetCharLength(objv[1]);
if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length)) {
- int ch = TclGetUCS4(objv[1], index);
+ 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,9 +1428,12 @@ StringIndexCmd(
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
- char buf[8] = "";
+ char buf[4] = "";
- length = TclUCS4ToUtf(ch, buf);
+ length = Tcl_UniCharToUtf(ch, buf);
+ if ((ch >= 0xD800) && (length < 3)) {
+ length += Tcl_UniCharToUtf(-1, buf + length);
+ }
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
}
}
@@ -1425,6 +1443,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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter */
+ int objc, /* Number of arguments */
+ Tcl_Obj *const objv[]) /* Argument objects */
+{
+ int length; /* String length */
+ int 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 +1517,7 @@ StringIndexCmd(
static int
StringIsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1455,24 +1530,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 +1569,7 @@ StringIsCmd(
&idx2) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum isOptions) idx2) {
+ switch ((enum isOptionsEnum) idx2) {
case OPT_STRICT:
strict = 1;
break;
@@ -1523,7 +1598,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 +1611,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 +1619,71 @@ 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, 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;
+ int 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);
@@ -1582,7 +1702,7 @@ StringIsCmd(
failat = stop - string1;
if (stop < end) {
result = 0;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
}
break;
@@ -1591,16 +1711,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);
@@ -1629,7 +1742,7 @@ StringIsCmd(
result = 0;
failat = stop - string1;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
} else {
/*
@@ -1645,7 +1758,6 @@ StringIsCmd(
break;
}
- failedIntParse:
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
@@ -1683,7 +1795,7 @@ StringIsCmd(
*/
failat = stop - string1;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
} else {
/*
@@ -1699,7 +1811,7 @@ StringIsCmd(
* well-formed lists.
*/
- if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) {
+ if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length2)) {
break;
}
@@ -1737,7 +1849,7 @@ StringIsCmd(
p++;
}
TclNewStringObj(tmpStr, string1, p-string1);
- failat = Tcl_GetCharLength(tmpStr);
+ failat = TclGetCharLength(tmpStr);
TclDecrRefCount(tmpStr);
break;
}
@@ -1760,6 +1872,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;
@@ -1794,10 +1909,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 +1930,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
/*
@@ -1837,7 +1953,7 @@ UniCharIsHexDigit(
static int
StringMapCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1870,10 +1986,11 @@ StringMapCmd(
/*
* 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;
@@ -1900,7 +2017,7 @@ StringMapCmd(
* adapt this code...
*/
- mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
+ mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (i=2 ; i<mapElemc ; i+=2) {
@@ -1908,7 +2025,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;
}
@@ -1943,7 +2060,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 +2070,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 +2086,10 @@ StringMapCmd(
* larger strings.
*/
- int mapLen;
- Tcl_UniChar *mapString, u2lc;
+ int mapLen, u2lc;
+ Tcl_UniChar *mapString;
- ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
+ ustring2 = TclGetUnicodeFromObj_(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/*
@@ -1981,7 +2098,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 +2106,20 @@ 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;
+ int *mapLens, *u2lc = NULL;
/*
* Precompute pointers to the Unicode string and length. This saves us
@@ -2011,13 +2128,13 @@ StringMapCmd(
* case.
*/
- mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
- mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
+ mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
+ mapLens = (int *)TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
if (nocase) {
- u2lc = 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 +2158,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 +2174,7 @@ StringMapCmd(
* Append the map value to the Unicode string.
*/
- Tcl_AppendUnicodeToObj(resultPtr,
+ TclAppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
@@ -2074,7 +2191,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 +2224,7 @@ StringMapCmd(
static int
StringMatchCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2159,7 +2276,7 @@ StringMatchCmd(
static int
StringRangeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2176,21 +2293,15 @@ StringRangeCmd(
* 'end' refers to the last character, not one past it.
*/
- length = Tcl_GetCharLength(objv[1]) - 1;
+ length = TclGetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], length, &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 +2326,12 @@ StringRangeCmd(
static int
StringReptCmd(
- 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 *string1;
- char *string2;
- int count, index, length1, length2;
+ int count;
Tcl_Obj *resultPtr;
if (objc != 3) {
@@ -2240,71 +2349,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 = 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,12 +2382,11 @@ StringReptCmd(
static int
StringRplcCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *ustring;
int first, last, length, end;
if (objc < 4 || objc > 5) {
@@ -2340,19 +2394,20 @@ StringRplcCmd(
return TCL_ERROR;
}
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
+ length = TclGetCharLength(objv[1]);
end = length - 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 */
@@ -2362,30 +2417,22 @@ StringRplcCmd(
* 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) {
- Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1,
- end - last);
+ if (last > end) {
+ last = end;
}
+
+ resultPtr = TclStringReplace(interp, objv[1], first,
+ last + 1 - first, (objc == 5) ? objv[4] : NULL,
+ TCL_STRING_IN_PLACE);
+
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
@@ -2411,7 +2458,7 @@ StringRplcCmd(
static int
StringRevCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2421,7 +2468,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 +2478,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 +2491,45 @@ StringRevCmd(
static int
StringStartCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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;
+ int 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);
+ (void)TclUniCharToUCS4(p, &ch);
for (cur = index; cur >= 0; cur--) {
int delta = 0;
- const char *next;
+ const Tcl_UniChar *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
- next = TclUtfPrev(p, string);
+ next = TclUCS4Prev(p, string);
do {
next += delta;
- delta = TclUtfToUniChar(next, &ch);
+ delta = TclUniCharToUCS4(next, &ch);
} while (next + delta < p);
p = next;
}
@@ -2493,7 +2537,8 @@ StringStartCmd(
cur += 1;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ TclNewIndexObj(obj, cur);
+ Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -2503,8 +2548,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 +2561,33 @@ StringStartCmd(
static int
StringEndCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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;
+ int 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);
+ p += TclUniCharToUCS4(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
@@ -2553,9 +2596,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 +2623,7 @@ StringEndCmd(
static int
StringEqualCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2591,7 +2635,7 @@ StringEqualCmd(
*/
const char *string2;
- int length2, i, match, nocase = 0, reqlength = -1;
+ int length, i, match, nocase = 0, reqlength = -1;
if (objc < 3 || objc > 6) {
str_cmp_args:
@@ -2601,11 +2645,11 @@ 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;
}
@@ -2654,7 +2698,7 @@ StringEqualCmd(
static int
StringCmpCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2674,201 +2718,12 @@ StringCmpCmd(
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(
+TclStringCmpOpts(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
@@ -2931,12 +2786,11 @@ int TclStringCmpOpts(
static int
StringCatCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +2800,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 +2829,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 +2845,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 +2870,7 @@ StringBytesCmd(
static int
StringLenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3033,7 +2880,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,7 +2904,7 @@ StringLenCmd(
static int
StringLowerCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3107,8 +2954,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,7 +2989,7 @@ StringLowerCmd(
static int
StringUpperCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3192,8 +3039,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,7 +3074,7 @@ StringUpperCmd(
static int
StringTitleCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3277,8 +3124,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 +3159,7 @@ StringTitleCmd(
static int
StringTrimCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3359,7 +3206,7 @@ StringTrimCmd(
static int
StringTrimLCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3405,7 +3252,7 @@ StringTrimLCmd(
static int
StringTrimRCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3458,12 +3305,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},
@@ -3547,17 +3397,17 @@ TclSubstOptions(
int
Tcl_SubstObjCmd(
- 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, TclNRSubstObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv);
}
int
TclNRSubstObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3595,16 +3445,16 @@ TclNRSubstObjCmd(
int
Tcl_SwitchObjCmd(
- 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, TclNRSwitchObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv);
}
int
TclNRSwitchObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3631,12 +3481,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 +3502,7 @@ TclNRSwitchObjCmd(
&index) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum options) index) {
+ switch ((enum switchOptionsEnum) index) {
/*
* General options.
*/
@@ -3760,7 +3610,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 +3623,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;
}
@@ -3922,8 +3775,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 +3794,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);
@@ -3992,7 +3845,7 @@ TclNRSwitchObjCmd(
*/
matchFound:
- ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
@@ -4022,7 +3875,7 @@ TclNRSwitchObjCmd(
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
- ctxPtr->line = ckalloc(objc * sizeof(int));
+ ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
@@ -4036,7 +3889,7 @@ TclNRSwitchObjCmd(
int k;
- ctxPtr->line = ckalloc(objc * sizeof(int));
+ ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
for (k=0; k < objc; k++) {
ctxPtr->line[k] = -1;
@@ -4076,9 +3929,9 @@ SwitchPostProc(
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
- CmdFrame *ctxPtr = data[1];
+ CmdFrame *ctxPtr = (CmdFrame *)data[1];
int pc = PTR2INT(data[2]);
- const char *pattern = data[3];
+ const char *pattern = (const char *)data[3];
int patternLength = strlen(pattern);
/*
@@ -4130,10 +3983,9 @@ SwitchPostProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ThrowObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4150,7 +4002,7 @@ 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(
@@ -4195,7 +4047,7 @@ Tcl_ThrowObjCmd(
int
Tcl_TimeObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4250,9 +4102,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 +4145,7 @@ Tcl_TimeObjCmd(
int
Tcl_TimeRateObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4304,14 +4156,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 +4175,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 +4192,7 @@ Tcl_TimeRateObjCmd(
i++;
break;
}
- switch (index) {
+ switch ((enum timeRateOptionsEnum)index) {
case TMRT_EV_DIRECT:
direct = objv[i];
break;
@@ -4355,6 +4207,8 @@ Tcl_TimeRateObjCmd(
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
+ case TMRT_LAST:
+ break;
}
}
@@ -4414,7 +4268,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 +4293,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 +4323,7 @@ Tcl_TimeRateObjCmd(
*/
measureOverhead = 0;
- Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
@@ -4683,13 +4537,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 +4554,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 +4573,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 +4589,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 +4612,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 +4634,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 +4649,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,17 +4691,17 @@ Tcl_TimeRateObjCmd(
int
Tcl_TryObjCmd(
- 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, TclNRTryObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv);
}
int
TclNRTryObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4935,10 +4790,10 @@ TclNRTryObjCmd(
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);
@@ -4947,7 +4802,7 @@ TclNRTryObjCmd(
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;
}
@@ -5049,12 +4904,12 @@ TryPostBody(
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
- int i, dummy, code, objc;
+ int i, code, objc;
int numHandlers = 0;
- handlersObj = data[0];
- finallyObj = data[1];
- objv = data[2];
+ handlersObj = (Tcl_Obj *)data[0];
+ finallyObj = (Tcl_Obj *)data[1];
+ objv = (Tcl_Obj **)data[2];
objc = PTR2INT(data[3]);
cmdObj = objv[0];
@@ -5097,11 +4952,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;
+ int 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) {
@@ -5122,8 +4978,8 @@ TryPostBody(
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 +5019,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 +5030,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) {
@@ -5267,9 +5123,9 @@ TryPostHandler(
Tcl_Obj *finallyObj;
int finallyIndex;
- objv = data[0];
- options = data[1];
- handlerKindObj = data[2];
+ objv = (Tcl_Obj **)data[0];
+ options = (Tcl_Obj *)data[1];
+ handlerKindObj = (Tcl_Obj *)data[2];
finallyIndex = PTR2INT(data[3]);
cmdObj = objv[0];
@@ -5351,9 +5207,9 @@ TryPostFinal(
{
Tcl_Obj *resultObj, *options, *cmdObj;
- resultObj = data[0];
- options = data[1];
- cmdObj = data[2];
+ resultObj = (Tcl_Obj *)data[0];
+ options = (Tcl_Obj *)data[1];
+ cmdObj = (Tcl_Obj *)data[2];
/*
* If the result wasn't OK, we need to adjust the result options.
@@ -5412,17 +5268,17 @@ TryPostFinal(
int
Tcl_WhileObjCmd(
- 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, TclNRWhileObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv);
}
int
TclNRWhileObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -5477,7 +5333,7 @@ TclListLines(
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);
const char *element = NULL, *next = NULL;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 1f3674c..7c5eead 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 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2013 by 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.
@@ -21,28 +21,16 @@
* Prototypes for procedures defined later in this file:
*/
-static ClientData DupDictUpdateInfo(ClientData clientData);
-static void FreeDictUpdateInfo(ClientData clientData);
-static void PrintDictUpdateInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void DisassembleDictUpdateInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static ClientData DupForeachInfo(ClientData clientData);
-static void FreeForeachInfo(ClientData clientData);
-static void PrintForeachInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void DisassembleForeachInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void PrintNewForeachInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void DisassembleNewForeachInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
+static AuxDataDupProc DupDictUpdateInfo;
+static AuxDataFreeProc FreeDictUpdateInfo;
+static AuxDataPrintProc PrintDictUpdateInfo;
+static AuxDataPrintProc DisassembleDictUpdateInfo;
+static AuxDataDupProc DupForeachInfo;
+static AuxDataFreeProc FreeForeachInfo;
+static AuxDataPrintProc PrintForeachInfo;
+static AuxDataPrintProc DisassembleForeachInfo;
+static AuxDataPrintProc PrintNewForeachInfo;
+static AuxDataPrintProc DisassembleNewForeachInfo;
static int CompileEachloopCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr, int collect);
@@ -260,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 */
@@ -314,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);
/*
@@ -403,9 +390,9 @@ TclCompileArraySetCmd(
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
- infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + sizeof(ForeachVarList *));
+ infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
- infoPtr->varLists[0] = 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;
@@ -522,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;
@@ -583,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 */
@@ -620,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);
@@ -763,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;
@@ -827,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
@@ -866,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 */
@@ -907,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;
@@ -950,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;
@@ -1016,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.
@@ -1141,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 */
@@ -1174,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 */
@@ -1317,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);
@@ -1776,9 +1789,9 @@ TclCompileDictUpdateCmd(
* that are to be used.
*/
- duiPtr = ckalloc(TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
+ duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
duiPtr->length = numVars;
- keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
+ keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
@@ -2250,35 +2263,35 @@ TclCompileDictWithCmd(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupDictUpdateInfo(
- ClientData clientData)
+ void *clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
- unsigned len;
+ size_t len;
- dui1Ptr = clientData;
- len = TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
- dui2Ptr = ckalloc(len);
+ dui1Ptr = (DictUpdateInfo *)clientData;
+ len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
+ dui2Ptr = (DictUpdateInfo *)ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
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 = clientData;
+ DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
for (i=0 ; i<duiPtr->length ; i++) {
@@ -2291,19 +2304,19 @@ 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 = clientData;
+ DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
Tcl_Obj *variables;
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);
@@ -2332,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 */
@@ -2406,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;
@@ -2451,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 */
@@ -2631,8 +2641,8 @@ TclCompileLmapCmd(
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. */
+ Command *cmdPtr, /* Points to the definition of the command
+ * being compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
@@ -2662,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_*) */
@@ -2694,7 +2703,7 @@ CompileEachloopCmd(
}
/*
- * Bail out if the body requires substitutions in order to insure correct
+ * Bail out if the body requires substitutions in order to ensure correct
* behaviour. [Bug 219166]
*/
@@ -2713,7 +2722,7 @@ CompileEachloopCmd(
*/
numLists = (numWords - 2)/2;
- infoPtr = ckalloc(TclOffset(ForeachInfo, varLists)
+ infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
@@ -2741,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 = ckalloc(TclOffset(ForeachVarList, varIndexes)
+ varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
@@ -2759,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;
@@ -2873,17 +2882,17 @@ 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 = clientData;
+ ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
- dupPtr = ckalloc(TclOffset(ForeachInfo, varLists)
+ dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
@@ -2892,7 +2901,7 @@ DupForeachInfo(
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
- dupListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes)
+ dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
@@ -2924,10 +2933,10 @@ 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 = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
int i;
@@ -2958,12 +2967,12 @@ 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 = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
@@ -2998,12 +3007,12 @@ 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 = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
@@ -3028,12 +3037,12 @@ 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 = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
@@ -3045,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);
@@ -3054,7 +3063,7 @@ DisassembleForeachInfo(
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
- Tcl_NewIntObj(infoPtr->loopCtTemp));
+ Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
@@ -3066,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);
}
@@ -3075,12 +3084,12 @@ 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 = clientData;
+ ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
@@ -3090,7 +3099,7 @@ DisassembleNewForeachInfo(
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
- Tcl_NewIntObj(infoPtr->loopCtTemp));
+ Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
@@ -3102,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);
}
@@ -3133,14 +3142,13 @@ 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 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
- char *bytes, *start;
+ const char *bytes, *start;
int i, j, len;
/*
@@ -3164,7 +3172,7 @@ TclCompileFormatCmd(
return TCL_ERROR;
}
- objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
for (i=0 ; i+2 < parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(objv[i]);
@@ -3179,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]);
@@ -3196,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;
@@ -3223,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') {
@@ -3256,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
@@ -3267,7 +3275,7 @@ TclCompileFormatCmd(
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
- char *b = Tcl_GetStringFromObj(tmpObj, &len);
+ const char *b = TclGetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
@@ -3301,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++;
@@ -3458,7 +3466,7 @@ TclPushVarName(
* assemble the corresponding token.
*/
- elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
+ elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -3512,7 +3520,7 @@ TclPushVarName(
* token.
*/
- elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
+ elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 3592663..d0cd6e9 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 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2013 by 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.
@@ -27,7 +27,6 @@ static void CompileReturnInternal(CompileEnv *envPtr,
Tcl_Obj *returnOpts);
static int IndexTailVarIfKnown(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-
/*
*----------------------------------------------------------------------
@@ -88,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 */
@@ -128,9 +126,12 @@ TclCompileGlobalCmd(
return TCL_ERROR;
}
- /* TODO: Consider what value can pass through the
- * IndexTailVarIfKnown() screen. Full CompileWord()
- * likely does not apply here. Push known value instead. */
+ /*
+ * TODO: Consider what value can pass through the
+ * IndexTailVarIfKnown() screen. Full CompileWord() likely does not
+ * apply here. Push known value instead.
+ */
+
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
}
@@ -167,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 */
@@ -181,7 +181,8 @@ TclCompileIfCmd(
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
- int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
+ int numBytes, j;
+ int jumpFalseDist, numWords, wordIdx, code;
const char *word;
int realCond = 1; /* Set to 0 for static conditions:
* "if 0 {..}" */
@@ -271,7 +272,7 @@ TclCompileIfCmd(
jumpIndex = jumpFalseFixupArray.next;
jumpFalseFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- jumpFalseFixupArray.fixup+jumpIndex);
+ jumpFalseFixupArray.fixup + jumpIndex);
}
code = TCL_OK;
}
@@ -318,7 +319,7 @@ TclCompileIfCmd(
}
jumpEndFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- jumpEndFixupArray.fixup+jumpIndex);
+ jumpEndFixupArray.fixup + jumpIndex);
/*
* Fix the target of the jumpFalse after the test. Generate a 4
@@ -330,7 +331,7 @@ TclCompileIfCmd(
TclAdjustStackDepth(-1, envPtr);
if (TclFixupForwardJumpToHere(envPtr,
- jumpFalseFixupArray.fixup+jumpIndex, 120)) {
+ jumpFalseFixupArray.fixup + jumpIndex, 120)) {
/*
* Adjust the code offset for the proceeding jump to the end
* of the "if" command.
@@ -413,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.
@@ -432,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);
}
}
}
@@ -470,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 */
@@ -588,7 +588,7 @@ TclCompileInfoCommandsCmd(
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
- char *bytes;
+ const char *bytes;
/*
* We require one compile-time known argument for the case we can compile.
@@ -605,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 "*\[?"
@@ -639,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. */
{
/*
@@ -667,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 */
@@ -716,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. */
{
/*
@@ -751,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 */
@@ -771,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 */
@@ -807,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 */
@@ -845,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 */
@@ -921,7 +914,7 @@ TclCompileLappendCmd(
CompileWord(envPtr, valueTokenPtr, interp, i);
valueTokenPtr = TokenAfter(valueTokenPtr);
}
- TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
+ TclEmitInstInt4( INST_LIST, numWords - 2, envPtr);
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr);
@@ -961,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 */
@@ -998,7 +990,7 @@ TclCompileLassignCmd(
*/
PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
- &isScalar, idx+2);
+ &isScalar, idx + 2);
/*
* Emit instructions to get the idx'th item out of the list value on
@@ -1037,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;
}
@@ -1065,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 */
@@ -1088,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.
@@ -1156,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 */
@@ -1242,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;
}
@@ -1270,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 */
@@ -1303,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 */
@@ -1317,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;
}
/*
@@ -1327,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;
}
@@ -1364,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;
}
@@ -1467,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;
}
@@ -1631,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 */
@@ -1775,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. */
{
/*
@@ -1803,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 */
@@ -1853,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 */
@@ -1875,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 */
@@ -1911,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 */
@@ -1948,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 */
@@ -2009,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 */
@@ -2073,14 +1919,14 @@ 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 */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
- int i, len, nocase, exact, sawLast, simple;
+ int len;
+ int i, nocase, exact, sawLast, simple;
const char *str;
/*
@@ -2184,7 +2030,7 @@ TclCompileRegexpCmd(
}
if (!simple) {
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2);
}
/*
@@ -2192,7 +2038,7 @@ TclCompileRegexpCmd(
*/
varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1);
if (simple) {
if (exact && !nocase) {
@@ -2238,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. */
{
/*
@@ -2267,7 +2112,8 @@ TclCompileRegsubCmd(
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
- int len, exact, quantified, result = TCL_ERROR;
+ int exact, quantified, result = TCL_ERROR;
+ int len;
if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
return TCL_ERROR;
@@ -2294,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;
}
@@ -2326,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;
@@ -2360,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;
@@ -2374,9 +2220,9 @@ 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);
+ CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
@@ -2413,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 */
@@ -2422,7 +2267,8 @@ TclCompileReturnCmd(
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
- int level, code, objc, size, status = TCL_OK;
+ int level, code, objc, status = TCL_OK;
+ int size;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
@@ -2454,7 +2300,7 @@ TclCompileReturnCmd(
* Allocate some working space.
*/
- objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
/*
* Scan through the return options. If any are unknown at compile time,
@@ -2505,7 +2351,7 @@ TclCompileReturnCmd(
*/
if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
} else {
/*
* No explict result argument, so default result is empty string.
@@ -2532,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;
}
@@ -2583,7 +2429,7 @@ TclCompileReturnCmd(
*/
if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
} else {
PushStringLiteral(envPtr, "");
}
@@ -2636,7 +2482,7 @@ TclCompileSyntaxError(
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);
@@ -2665,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 */
@@ -2772,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 */
@@ -2814,12 +2658,12 @@ TclCompileVariableCmd(
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
- if (i+1 < numWords) {
+ if (i + 1 < numWords) {
/*
* A value has been given: set the variable, pop the value
*/
- CompileWord(envPtr, valueTokenPtr, interp, i+1);
+ CompileWord(envPtr, valueTokenPtr, interp, i + 1);
Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
@@ -2854,13 +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 len, n = varTokenPtr->numComponents;
+ int n = varTokenPtr->numComponents;
+ int len;
Tcl_Token *lastTokenPtr;
int full, localIndex;
@@ -2895,7 +2740,7 @@ IndexTailVarIfKnown(
tailName = TclGetStringFromObj(tailPtr, &len);
if (len) {
- if (*(tailName+len-1) == ')') {
+ if (*(tailName + len - 1) == ')') {
/*
* Possible array: bail out
*/
@@ -2909,7 +2754,7 @@ IndexTailVarIfKnown(
*/
for (p = tailName + len -1; p > tailName; p--) {
- if ((*p == ':') && (*(p-1) == ':')) {
+ if ((*p == ':') && (*(p - 1) == ':')) {
p++;
break;
}
@@ -2946,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 */
@@ -2971,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 */
@@ -2993,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 355c741..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 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2010 by 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.
@@ -23,14 +23,10 @@
* Prototypes for procedures defined later in this file:
*/
-static ClientData DupJumptableInfo(ClientData clientData);
-static void FreeJumptableInfo(ClientData clientData);
-static void PrintJumptableInfo(ClientData clientData,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
-static void DisassembleJumptableInfo(ClientData clientData,
- Tcl_Obj *dictObj, ByteCode *codePtr,
- unsigned int pcOffset);
+static AuxDataDupProc DupJumptableInfo;
+static AuxDataFreeProc FreeJumptableInfo;
+static AuxDataPrintProc PrintJumptableInfo;
+static AuxDataPrintProc DisassembleJumptableInfo;
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, const char *identity,
int instruction, CompileEnv *envPtr);
@@ -45,13 +41,12 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
CompileEnv *envPtr);
static void IssueSwitchChainedTests(Tcl_Interp *interp,
CompileEnv *envPtr, int mode, int noCase,
- int valueIndex, int numWords,
- Tcl_Token **bodyToken, int *bodyLines,
- int **bodyNext);
-static void IssueSwitchJumpTable(Tcl_Interp *interp,
- CompileEnv *envPtr, int valueIndex,
int numWords, Tcl_Token **bodyToken,
- int *bodyLines, int **bodyContLines);
+ int *bodyLines, int **bodyNext);
+static void IssueSwitchJumpTable(Tcl_Interp *interp,
+ CompileEnv *envPtr, int numWords,
+ Tcl_Token **bodyToken, int *bodyLines,
+ int **bodyContLines);
static int IssueTryClausesInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
@@ -131,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 */
@@ -225,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 */
@@ -260,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);
@@ -278,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);
@@ -297,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 */
@@ -329,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 */
@@ -361,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 */
@@ -393,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 */
@@ -425,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 */
@@ -449,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
@@ -461,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 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
};
int t, range, allowEmpty = 0, end;
InstStringClassType strClassType;
@@ -531,7 +575,7 @@ TclCompileStringIsCmd(
CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
- switch ((enum isClasses) t) {
+ switch ((enum isClassesEnum) t) {
case STR_IS_ALNUM:
strClassType = STR_CLASS_ALNUM;
goto compileStrClass;
@@ -565,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,14 +739,11 @@ TclCompileStringIsCmd(
}
switch (t) {
- case STR_IS_INT:
- PUSH( "1");
- OP( EQ);
- break;
case STR_IS_WIDE:
PUSH( "2");
OP( LE);
break;
+ case STR_IS_INT:
case STR_IS_ENTIER:
PUSH( "3");
OP( LE);
@@ -707,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);
@@ -813,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 */
@@ -835,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);
@@ -860,7 +915,7 @@ TclCompileStringMapCmd(
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
- char *bytes;
+ const char *bytes;
int len;
/*
@@ -883,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) {
@@ -897,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);
@@ -916,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 */
@@ -938,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;
}
@@ -947,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;
}
@@ -962,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( "");
@@ -992,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 */
@@ -1012,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;
}
@@ -1021,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;
}
@@ -1040,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
@@ -1049,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);
@@ -1095,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);
@@ -1148,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;
@@ -1168,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;
}
@@ -1194,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 */
@@ -1222,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 */
@@ -1250,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 */
@@ -1354,7 +1401,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
StringClassDesc const tclStringClassTable[] = {
@@ -1371,7 +1418,8 @@ StringClassDesc const tclStringClassTable[] = {
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
- {NULL, NULL}
+ {"unicode", Tcl_UniCharIsUnicode},
+ {"", NULL}
};
/*
@@ -1399,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 */
@@ -1415,7 +1462,7 @@ TclCompileSubstCmd(
return TCL_ERROR;
}
- objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
TclNewObj(objv[objc]);
@@ -1497,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);
@@ -1513,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;
@@ -1732,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 */
@@ -1908,10 +1954,10 @@ TclCompileSwitchCmd(
if (maxLen < 2) {
return TCL_ERROR;
}
- bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen);
- bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen);
- bodyLines = ckalloc(sizeof(int) * maxLen);
- bodyContLines = ckalloc(sizeof(int*) * maxLen);
+ bodyTokenArray = (Tcl_Token *)ckalloc(sizeof(Tcl_Token) * maxLen);
+ bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * maxLen);
+ bodyLines = (int *)ckalloc(sizeof(int) * maxLen);
+ bodyContLines = (int **)ckalloc(sizeof(int*) * maxLen);
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
numWords = 0;
@@ -1949,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) {
@@ -1970,9 +2016,9 @@ TclCompileSwitchCmd(
* Multi-word definition of patterns & actions.
*/
- bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
- bodyLines = ckalloc(sizeof(int) * numWords);
- bodyContLines = ckalloc(sizeof(int*) * numWords);
+ bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * numWords);
+ bodyLines = (int *)ckalloc(sizeof(int) * numWords);
+ bodyContLines = (int **)ckalloc(sizeof(int*) * numWords);
bodyTokenArray = NULL;
for (i=0 ; i<numWords ; i++) {
/*
@@ -2018,10 +2064,10 @@ TclCompileSwitchCmd(
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
- IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken,
+ IssueSwitchJumpTable(interp, envPtr, numWords, bodyToken,
bodyLines, bodyContLines);
} else {
- IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex,
+ IssueSwitchChainedTests(interp, envPtr, mode, noCase,
numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
@@ -2062,7 +2108,6 @@ IssueSwitchChainedTests(
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
- int valueIndex, /* The value to match against. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -2092,8 +2137,8 @@ IssueSwitchChainedTests(
contFixIndex = -1;
contFixCount = 0;
- fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
- fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens);
+ fixupArray = (JumpFixup *)TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
+ fixupTargetArray = (unsigned int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens);
memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
fixupCount = 0;
foundDefault = 0;
@@ -2311,7 +2356,6 @@ static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int valueIndex, /* The value to match against. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -2336,10 +2380,10 @@ IssueSwitchJumpTable(
* Start by allocating the jump table itself, plus some workspace.
*/
- jtPtr = ckalloc(sizeof(JumptableInfo));
+ jtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
- finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
+ finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
foundDefault = 0;
mustGenerate = 1;
@@ -2503,12 +2547,12 @@ IssueSwitchJumpTable(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupJumptableInfo(
- ClientData clientData)
+ void *clientData)
{
- JumptableInfo *jtPtr = clientData;
- JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo));
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
+ JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
@@ -2525,9 +2569,9 @@ DupJumptableInfo(
static void
FreeJumptableInfo(
- ClientData clientData)
+ void *clientData)
{
- JumptableInfo *jtPtr = clientData;
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
ckfree(jtPtr);
@@ -2535,12 +2579,12 @@ FreeJumptableInfo(
static void
PrintJumptableInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
+ TCL_UNUSED(ByteCode *),
unsigned int pcOffset)
{
- JumptableInfo *jtPtr = clientData;
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
@@ -2548,7 +2592,7 @@ PrintJumptableInfo(
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
- keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
if (i++) {
@@ -2564,25 +2608,25 @@ 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 = clientData;
+ 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);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
- keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
+ 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);
}
@@ -2610,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 */
@@ -2657,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 */
@@ -2689,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) {
@@ -2761,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;
@@ -2798,12 +2839,12 @@ TclCompileTryCmd(
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
- handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
- matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
+ handlerTokens = (Tcl_Token**)TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
+ matchClauses = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
- matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers);
- resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
- optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
+ matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
+ resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
+ optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
@@ -2823,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;
@@ -2866,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) {
@@ -2885,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) {
@@ -3067,9 +3108,9 @@ IssueTryClausesInstructions(
* Slight overallocation, but reduces size of this function.
*/
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- noError = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
+ forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
+ noError = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
noError[i] = -1;
@@ -3080,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.
@@ -3091,12 +3132,12 @@ 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);
} else {
- notECJumpSource = -1; /* LINT */
+ notECJumpSource = -1;
}
OP( POP);
@@ -3278,8 +3319,8 @@ IssueTryClausesFinallyInstructions(
* Slight overallocation, but reduces size of this function.
*/
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
+ forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
int noTrapError, trapError;
@@ -3291,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.
@@ -3302,12 +3343,12 @@ 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);
} else {
- notECJumpSource = -1; /* LINT */
+ notECJumpSource = -1;
}
OP( POP);
@@ -3574,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 */
@@ -3631,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++;
@@ -3713,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 */
@@ -3891,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) {
@@ -3934,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 */
@@ -4184,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);
@@ -4195,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);
@@ -4206,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,
@@ -4218,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,
@@ -4230,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,
@@ -4242,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,
@@ -4254,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,
@@ -4266,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 */
@@ -4297,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);
@@ -4308,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);
@@ -4319,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);
@@ -4330,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);
@@ -4341,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);
@@ -4352,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);
@@ -4363,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,
@@ -4375,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);
@@ -4386,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);
@@ -4397,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);
@@ -4408,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);
@@ -4419,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);
@@ -4430,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 */
@@ -4487,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 4e145b8..9791cb3 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 /* ) */,
@@ -623,7 +633,7 @@ ParseExpr(
TclParseInit(interp, start, numBytes, parsePtr);
- nodes = attemptckalloc(nodesAvailable * sizeof(OpNode));
+ nodes = (OpNode *)attemptckalloc(nodesAvailable * sizeof(OpNode));
if (nodes == NULL) {
TclNewLiteralStringObj(msg, "not enough memory to parse expression");
errCode = "NOMEM";
@@ -666,9 +676,10 @@ ParseExpr(
OpNode *newPtr = NULL;
do {
- if (size <= UINT_MAX/sizeof(OpNode)) {
- newPtr = attemptckrealloc(nodes, size * sizeof(OpNode));
- }
+ if (size <= UINT_MAX/sizeof(OpNode)) {
+ newPtr = (OpNode *) attemptckrealloc(nodes,
+ size * sizeof(OpNode));
+ }
} while ((newPtr == NULL)
&& ((size -= (size - nodesUsed) / 2) > nodesUsed));
if (newPtr == NULL) {
@@ -700,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);
@@ -734,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,
@@ -911,7 +952,7 @@ ParseExpr(
break;
case SCRIPT: {
- Tcl_Parse *nestedPtr =
+ Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
@@ -1830,15 +1871,15 @@ Tcl_ParseExpr(
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList; /* List to hold the literals. */
Tcl_Obj *funcList; /* List to hold the functon names. */
- Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
+ TclNewObj(litList);
+ TclNewObj(funcList);
if (numBytes < 0) {
numBytes = (start ? strlen(start) : 0);
}
- TclNewObj(litList);
- TclNewObj(funcList);
code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
@@ -1886,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;
@@ -1901,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;
@@ -2003,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);
@@ -2029,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) {
@@ -2066,13 +2146,13 @@ ParseLexeme(
if (!TclIsBareword(*start) || *start == '_') {
if (Tcl_UtfCharComplete(start, numBytes)) {
- scanned = TclUtfToUniChar(start, &ch);
+ scanned = TclUtfToUCS4(start, &ch);
} else {
- char utfBytes[TCL_UTF_MAX];
+ char utfBytes[8];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
- scanned = TclUtfToUniChar(utfBytes, &ch);
+ scanned = TclUtfToUCS4(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
@@ -2119,9 +2199,9 @@ TclCompileExpr(
int optimize) /* 0 for one-off expressions. */
{
OpNode *opTree = NULL; /* Will point to the tree of operators */
- Tcl_Obj *litList; /* List to hold the literals */
- Tcl_Obj *funcList; /* List to hold the functon names*/
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Obj *litList; /* List to hold the literals */
+ Tcl_Obj *funcList; /* List to hold the functon names*/
+ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions */
int code;
@@ -2143,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 {
@@ -2186,29 +2266,25 @@ 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
* bytecode, so there's no need to tend to TIP 280 issues.
*/
- envPtr = TclStackAlloc(interp, sizeof(CompileEnv));
+ envPtr = (CompileEnv *)TclStackAlloc(interp, sizeof(CompileEnv));
TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
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 = byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
- Tcl_DecrRefCount(byteCodeObj);
+ TclReleaseByteCode(byteCodePtr);
return code;
}
@@ -2276,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);
/*
@@ -2293,13 +2369,13 @@ CompileExprTree(
break;
}
case QUESTION:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
@@ -2312,7 +2388,7 @@ CompileExprTree(
break;
case AND:
case OR:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
@@ -2385,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);
@@ -2395,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;
@@ -2430,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)) {
@@ -2485,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)) {
@@ -2543,7 +2621,7 @@ TclSingleOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
OpNode nodes[2];
Tcl_Obj *const *litObjv = objv + 1;
@@ -2575,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.
@@ -2601,10 +2679,10 @@ TclSortingOpCmd(
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
- TclOpCmdClientData *occdPtr = clientData;
- Tcl_Obj **litObjv = TclStackAlloc(interp,
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
+ Tcl_Obj **litObjv = (Tcl_Obj **)TclStackAlloc(interp,
2 * (objc-2) * sizeof(Tcl_Obj *));
- OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
+ OpNode *nodes = (OpNode *)TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
unsigned char lexeme;
int i, lastAnd = 1;
Tcl_Obj *const *litObjPtrPtr = litObjv;
@@ -2676,12 +2754,12 @@ TclVariadicOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
int code;
if (objc < 2) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(occdPtr->i.identity));
return TCL_OK;
}
@@ -2709,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);
}
@@ -2731,7 +2809,7 @@ TclVariadicOpCmd(
return code;
} else {
Tcl_Obj *const *litObjv = objv + 1;
- OpNode *nodes = TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
+ OpNode *nodes = (OpNode *)TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
int i, lastOp = OT_LITERAL;
nodes[0].lexeme = START;
@@ -2795,7 +2873,7 @@ TclNoIdentOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 323ada8..1ab7301 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 by 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 = 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
*/
@@ -1107,12 +1150,12 @@ TclCleanupByteCode(
(char *) codePtr);
if (hePtr) {
- ReleaseCmdWordData(Tcl_GetHashValue(hePtr));
+ ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
- 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 = 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 = 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 = 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);
}
/*
@@ -1460,7 +1499,7 @@ TclInitCompileEnv(
* non-compiling evaluator
*/
- envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc));
+ envPtr->extCmdMapPtr = (ExtCmdLoc *)ckalloc(sizeof(ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
@@ -1516,7 +1555,7 @@ TclInitCompileEnv(
* ...) which may make change the type as well.
*/
- CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ CmdFrame *ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
int pc = 0;
*ctxPtr = *invoker;
@@ -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,25 +2051,25 @@ 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);
/*
* TIP #280. Scan the words and compute the extended location information.
- * The map first contain full per-word line information for use by the
+ * At first the map first contains full per-word line information for use by the
* compiler. This is later replaced by a reduced form which signals
* non-literal words, stored in 'wlines'.
*/
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;
@@ -2063,7 +2104,7 @@ CompileCommandTokens(
}
}
- /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */
+ /* If cmdPtr != NULL, try to call cmdPtr->compileProc */
if (cmdPtr) {
code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr);
}
@@ -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;
@@ -2129,10 +2170,10 @@ TclCompileScript(
}
/*
* Check depth to avoid overflow of the C execution stack by too many
- * nested calls of TclCompileScript (considering interp recursionlimit).
- * Factor 5/4 (1.25) is used to avoid too mistaken limit recognition
- * during "mixed" evaluation and compilation process (nested eval+compile)
- * and is good enough for default recursionlimit (1000).
+ * nested calls of TclCompileScript, considering interp recursionlimit.
+ * Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the
+ * limit during "mixed" evaluation and compilation process (nested
+ * eval+compile) and is good enough for default recursionlimit (1000).
*/
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -2150,7 +2191,7 @@ TclCompileScript(
* many nested compilations (body enclosed in body) can cause abnormal
* program termination with a stack overflow exception, bug [fec0c17d39].
*/
- Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = (Tcl_Parse *)ckalloc(sizeof(Tcl_Parse));
do {
const char *next;
@@ -2275,8 +2316,8 @@ TclCompileScript(
*
* TclCompileTokens --
*
- * Given an array of tokens parsed from a Tcl command (e.g., the tokens
- * that make up a word) this procedure emits instructions to evaluate the
+ * Given an array of tokens parsed from a Tcl command, e.g. the tokens
+ * that make up a word, emits instructions to evaluate the
* tokens and concatenate their values to form a single result value on
* the interpreter's runtime evaluation stack.
*
@@ -2298,8 +2339,8 @@ TclCompileVarSubst(
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
- int nameBytes = tokenPtr[1].size;
- int i, localVar, localVarName = 1;
+ int i, localVar, nameBytes = tokenPtr[1].size;
+ int localVarName = 1;
/*
* Determine how the variable name should be handled: if it contains any
@@ -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;
@@ -2408,7 +2448,7 @@ TclCompileTokens(
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
- clPosition = ckalloc(maxNumCL * sizeof(int));
+ clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 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] == ' ') &&
@@ -2449,7 +2488,7 @@ TclCompileTokens(
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = ckrealloc(clPosition,
+ clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
@@ -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;
@@ -2725,14 +2762,14 @@ TclCompileNoOp(
*
* TclInitByteCodeObj --
*
- * Create a ByteCode structure and initialize it from a CompileEnv
+ * Creates a ByteCode structure and initializes it from a CompileEnv
* compilation environment structure. The ByteCode structure is smaller
* and contains just that information needed to execute the bytecode
* instructions resulting from compiling a Tcl script. The resulting
* structure is placed in the specified object.
*
* Results:
- * A newly constructed ByteCode object is stored in the internal
+ * A newly-constructed ByteCode object is stored in the internal
* representation of the objPtr.
*
* Side effects:
@@ -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 */
@@ -2794,13 +2864,14 @@ TclInitByteCodeObj(
namespacePtr = envPtr->iPtr->globalNsPtr;
}
- p = ckalloc(structureSize);
+ p = (unsigned char *)ckalloc(structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
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 = 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.
*
*----------------------------------------------------------------------
*/
@@ -3061,7 +3125,7 @@ TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
- CompileEnv *envPtr = envArgPtr;
+ CompileEnv *envPtr = (CompileEnv *)envArgPtr;
/* The CompileEnv containing the code array to
* be doubled in size. */
@@ -3075,14 +3139,14 @@ TclExpandCodeArray(
size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
- envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes);
+ 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 = ckalloc(newBytes);
+ unsigned char *newPtr = (unsigned char *)ckalloc(newBytes);
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
@@ -3142,14 +3206,14 @@ EnterCmdStartData(
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
- envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes);
+ envPtr->cmdMapPtr = (CmdLocation *)ckrealloc(envPtr->cmdMapPtr, newBytes);
} else {
/*
* envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
- CmdLocation *newPtr = ckalloc(newBytes);
+ CmdLocation *newPtr = (CmdLocation *)ckalloc(newBytes);
memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
envPtr->cmdMapPtr = newPtr;
@@ -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) {
/*
@@ -3268,16 +3332,16 @@ EnterCmdWordData(
size_t newElems = (currElems ? 2*currElems : 1);
size_t newBytes = newElems * sizeof(ECL);
- eclPtr->loc = ckrealloc(eclPtr->loc, newBytes);
+ eclPtr->loc = (ECL *)ckrealloc(eclPtr->loc, newBytes);
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc[eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
- ePtr->line = ckalloc(numWords * sizeof(int));
- ePtr->next = ckalloc(numWords * sizeof(int *));
+ ePtr->line = (int *)ckalloc(numWords * sizeof(int));
+ ePtr->next = (int **)ckalloc(numWords * sizeof(int *));
ePtr->nline = numWords;
- wwlines = ckalloc(numWords * sizeof(int));
+ wwlines = (int *)ckalloc(numWords * sizeof(int));
last = cmd;
wordLine = line;
@@ -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,23 +3404,23 @@ 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);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
- ckrealloc(envPtr->exceptArrayPtr, newBytes);
+ (ExceptionRange *)ckrealloc(envPtr->exceptArrayPtr, newBytes);
envPtr->exceptAuxArrayPtr =
- ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
+ (ExceptionAux *)ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
- ExceptionRange *newPtr = ckalloc(newBytes);
- ExceptionAux *newPtr2 = ckalloc(newBytes2);
+ ExceptionRange *newPtr = (ExceptionRange *)ckalloc(newBytes);
+ ExceptionAux *newPtr2 = (ExceptionAux *)ckalloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
@@ -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)) {
@@ -3438,7 +3502,7 @@ TclGetInnermostExceptionRange(
*
* Adds a place that wants to break/continue to the loop exception range
* tracking that will be fixed up once the loop can be finalized. These
- * functions will generate an INST_JUMP4 that will be fixed up during the
+ * functions generate an INST_JUMP4 that is fixed up during the
* loop finalization.
*
* ---------------------------------------------------------------------
@@ -3459,11 +3523,11 @@ TclAddLoopBreakFixup(
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
- auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets,
+ auxPtr->breakTargets = (unsigned int *)ckrealloc(auxPtr->breakTargets,
sizeof(int) * auxPtr->allocBreakTargets);
} else {
auxPtr->breakTargets =
- ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
+ (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
}
}
auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
@@ -3485,11 +3549,11 @@ TclAddLoopContinueFixup(
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
- auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets,
+ auxPtr->continueTargets = (unsigned int *)ckrealloc(auxPtr->continueTargets,
sizeof(int) * auxPtr->allocContinueTargets);
} else {
auxPtr->continueTargets =
- ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
+ (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
}
}
auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
@@ -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,19 +3767,19 @@ 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) {
envPtr->auxDataArrayPtr =
- ckrealloc(envPtr->auxDataArrayPtr, newBytes);
+ (AuxData *)ckrealloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
* envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
- AuxData *newPtr = ckalloc(newBytes);
+ AuxData *newPtr = (AuxData *)ckalloc(newBytes);
memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
envPtr->auxDataArrayPtr = newPtr;
@@ -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,18 +3856,18 @@ 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) {
- fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes);
+ fixupArrayPtr->fixup = (JumpFixup *)ckrealloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
* fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
- JumpFixup *newPtr = ckalloc(newBytes);
+ JumpFixup *newPtr = (JumpFixup *)ckalloc(newBytes);
memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
fixupArrayPtr->fixup = newPtr;
@@ -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 207f3af..87fb783 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,9 +180,9 @@ 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 */
+typedef struct {
+ Tcl_Size srcOffset; /* Command location to find the entry. */
+ Tcl_Size nline; /* Number of words in the command */
int *line; /* Line information for all words in the
* command. */
int **next; /* Transient information used by the compiler
@@ -190,7 +190,7 @@ typedef struct ECL {
* lines. */
} ECL;
-typedef struct ExtCmdLoc {
+typedef struct {
int type; /* Context type. */
int start; /* Starting line for compiled script. Needed
* for the extended recompile check in
@@ -198,8 +198,8 @@ typedef struct ExtCmdLoc {
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,7 +378,7 @@ 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. */
@@ -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
@@ -1069,7 +1097,6 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int 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,
@@ -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 int TclCreateAuxData(void *clientData,
const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE int 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 Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
+ int length, TCL_HASH_TYPE hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
@@ -1113,7 +1140,7 @@ 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 Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
int create, CompileEnv *envPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
@@ -1123,8 +1150,9 @@ 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);
@@ -1161,40 +1189,15 @@ 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 int TclSingleOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclSortingOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+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);
@@ -1208,10 +1211,9 @@ MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
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,
+MODULE_SCOPE int TclPushProcCallFrame(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int isLambda);
-
/*
*----------------------------------------------------------------
@@ -1223,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) \
@@ -1234,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.
@@ -1282,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)
@@ -1527,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);
@@ -1571,9 +1550,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
*/
#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
@@ -1589,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) \
@@ -1602,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) \
@@ -1663,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)]; \
@@ -1705,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).
*/
@@ -1841,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 9756979..36d37ec 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);
/*
*----------------------------------------------------------------------
@@ -77,11 +76,11 @@ Tcl_RegisterConfig(
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
- QCCD *cdPtr = ckalloc(sizeof(QCCD));
+ QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
- cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
+ cdPtr->encoding = (char *)ckalloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
@@ -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.
@@ -197,7 +196,7 @@ QueryConfigObjCmd(
int objc,
Tcl_Obj *const *objv)
{
- QCCD *cdPtr = clientData;
+ QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
@@ -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), 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]), NULL);
return TCL_ERROR;
}
@@ -324,16 +323,16 @@ static void
QueryConfigDelete(
ClientData clientData)
{
- QCCD *cdPtr = clientData;
+ QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
- ckfree((char *)cdPtr->encoding);
+ ckfree(cdPtr->encoding);
}
- ckfree((char *)cdPtr);
+ ckfree(cdPtr);
}
/*
@@ -357,7 +356,7 @@ static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
- Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
+ Tcl_Obj *pDB = (Tcl_Obj *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
if (pDB == NULL) {
pDB = Tcl_NewDictObj();
@@ -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 = clientData;
-
- Tcl_DecrRefCount(pDB);
+ Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
diff --git a/generic/tclDate.c b/generic/tclDate.c
index ebe499d..3bdbdb2 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -352,7 +352,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
@@ -2744,7 +2743,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 */
@@ -2754,7 +2753,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2762,7 +2760,7 @@ TclClockOldscanObjCmd(
return TCL_ERROR;
}
- yyInput = Tcl_GetString( objv[1] );
+ yyInput = TclGetString( objv[1] );
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 11e8e59..f9b36ba 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 *lengthPtr);
+ int *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,58 +198,69 @@ 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 length);
+ 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,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
const char *message, int length);
/* 68 */
EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp);
@@ -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_DEPRECATED("Use Tcl_EvalTokensStandard")
+Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int 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_Size 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,67 +1876,177 @@ 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 */
-/* Slot 650 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 *mountPoint, const char *zipname,
+ 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 char *mountPoint, unsigned char *data,
+ size_t datalen, int copy);
+/* 636 */
+EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr);
+/* 637 */
+EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ TCL_HASH_TYPE numBytes);
+/* 638 */
+EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr);
+/* 639 */
+EXTERN void Tcl_StoreInternalRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr,
+ const Tcl_ObjInternalRep *irPtr);
+/* 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 * TclGetBytesFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *numBytesPtr);
+/* 650 */
+EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, void *numBytesPtr);
/* 651 */
-EXTERN char * TclGetStringFromObj_(Tcl_Obj *objPtr,
- void *lengthPtr);
+EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr);
/* 652 */
-EXTERN unsigned short * TclGetUnicodeFromObj_(Tcl_Obj *objPtr,
+EXTERN unsigned short * TclGetUnicodeFromObj(Tcl_Obj *objPtr,
void *lengthPtr);
/* 653 */
-EXTERN unsigned char * TclGetByteArrayFromObj_(Tcl_Obj *objPtr,
+EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr,
void *numBytesPtr);
-/* 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 */
-/* Slot 661 is reserved */
-/* Slot 662 is reserved */
-/* Slot 663 is reserved */
-/* Slot 664 is reserved */
-/* 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 */
-/* 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 */
+/* 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);
+/* 661 */
+EXTERN int TclListObjGetElements(Tcl_Interp *interp,
+ Tcl_Obj *listPtr, void *objcPtr,
+ Tcl_Obj ***objvPtr);
+/* 662 */
+EXTERN int TclListObjLength(Tcl_Interp *interp,
+ Tcl_Obj *listPtr, void *lengthPtr);
+/* 663 */
+EXTERN int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
+ void *sizePtr);
+/* 664 */
+EXTERN int TclSplitList(Tcl_Interp *interp, const char *listStr,
+ void *argcPtr, const char ***argvPtr);
+/* 665 */
+EXTERN void TclSplitPath(const char *path, void *argcPtr,
+ const char ***argvPtr);
+/* 666 */
+EXTERN Tcl_Obj * TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr);
+/* 667 */
+EXTERN int TclParseArgsObjv(Tcl_Interp *interp,
+ const Tcl_ArgvInfo *argTable, void *objcPtr,
+ Tcl_Obj *const *objv, Tcl_Obj ***remObjv);
+/* 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);
+/* 676 */
+EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc2,
+ void *clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 677 */
+EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp,
+ Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc2 *objProc2,
+ void *clientData,
+ Tcl_CmdObjTraceDeleteProc *delProc);
+/* 678 */
+EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc,
+ Tcl_ObjCmdProc2 *nreProc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 679 */
+EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc2, void *clientData,
+ ptrdiff_t objc, Tcl_Obj *const objv[]);
+/* 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,
+ ptrdiff_t 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 */
@@ -1892,22 +2063,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 */
@@ -1923,27 +2094,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 *lengthPtr); /* 33 */
+ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
- 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 */
@@ -1953,93 +2124,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 length); /* 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, int 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 */
@@ -2051,49 +2222,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 */
@@ -2101,27 +2272,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 */
@@ -2130,135 +2301,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 */
@@ -2267,19 +2438,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, int 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 */
@@ -2291,36 +2462,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_Size 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 */
@@ -2334,24 +2505,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 */
@@ -2359,7 +2530,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 */
@@ -2375,30 +2546,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 */
@@ -2406,8 +2577,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 */
@@ -2416,12 +2587,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 */
@@ -2434,13 +2605,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 */
@@ -2467,43 +2638,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 */
@@ -2511,11 +2682,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 */
@@ -2526,15 +2697,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 */
@@ -2546,61 +2717,61 @@ 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);
- void (*reserved650)(void);
- char * (*tclGetStringFromObj_) (Tcl_Obj *objPtr, void *lengthPtr); /* 651 */
- unsigned short * (*tclGetUnicodeFromObj_) (Tcl_Obj *objPtr, void *lengthPtr); /* 652 */
- unsigned char * (*tclGetByteArrayFromObj_) (Tcl_Obj *objPtr, void *numBytesPtr); /* 653 */
- void (*reserved654)(void);
- void (*reserved655)(void);
- void (*reserved656)(void);
- void (*reserved657)(void);
- void (*reserved658)(void);
- void (*reserved659)(void);
- void (*reserved660)(void);
- void (*reserved661)(void);
- void (*reserved662)(void);
- void (*reserved663)(void);
- void (*reserved664)(void);
- 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);
- 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);
+ 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 *mountPoint, const char *zipname, const char *passwd); /* 632 */
+ int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
+ Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
+ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
+ void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */
+ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE numBytes); /* 637 */
+ Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
+ void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */
+ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
+ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
+ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
+ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
+ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, 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 * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */
+ unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *numBytesPtr); /* 650 */
+ char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 651 */
+ unsigned short * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 652 */
+ unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, void *numBytesPtr); /* 653 */
+ 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 */
+ int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr); /* 661 */
+ int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *lengthPtr); /* 662 */
+ int (*tclDictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr); /* 663 */
+ int (*tclSplitList) (Tcl_Interp *interp, const char *listStr, void *argcPtr, const char ***argvPtr); /* 664 */
+ void (*tclSplitPath) (const char *path, void *argcPtr, const char ***argvPtr); /* 665 */
+ Tcl_Obj * (*tclFSSplitPath) (Tcl_Obj *pathPtr, void *lenPtr); /* 666 */
+ int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */
+ 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 */
+ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
+ Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
+ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
+ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, ptrdiff_t objc, Tcl_Obj *const objv[]); /* 679 */
+ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
+ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, ptrdiff_t 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 */
@@ -2824,8 +2995,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 \
@@ -2958,8 +3129,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 \
@@ -2980,8 +3151,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 \
@@ -3123,8 +3294,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 \
@@ -3286,18 +3457,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 \
@@ -3306,8 +3477,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 \
@@ -3338,14 +3509,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 \
@@ -3896,64 +4067,116 @@ 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 */
-/* Slot 650 is reserved */
-#define TclGetStringFromObj_ \
- (tclStubsPtr->tclGetStringFromObj_) /* 651 */
-#define TclGetUnicodeFromObj_ \
- (tclStubsPtr->tclGetUnicodeFromObj_) /* 652 */
-#define TclGetByteArrayFromObj_ \
- (tclStubsPtr->tclGetByteArrayFromObj_) /* 653 */
-/* 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 */
-/* Slot 661 is reserved */
-/* Slot 662 is reserved */
-/* Slot 663 is reserved */
-/* Slot 664 is reserved */
-/* 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 */
-/* 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_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 TclGetBytesFromObj \
+ (tclStubsPtr->tclGetBytesFromObj) /* 649 */
+#define Tcl_GetBytesFromObj \
+ (tclStubsPtr->tcl_GetBytesFromObj) /* 650 */
+#define TclGetStringFromObj \
+ (tclStubsPtr->tclGetStringFromObj) /* 651 */
+#define TclGetUnicodeFromObj \
+ (tclStubsPtr->tclGetUnicodeFromObj) /* 652 */
+#define TclGetByteArrayFromObj \
+ (tclStubsPtr->tclGetByteArrayFromObj) /* 653 */
+#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 */
+#define TclListObjGetElements \
+ (tclStubsPtr->tclListObjGetElements) /* 661 */
+#define TclListObjLength \
+ (tclStubsPtr->tclListObjLength) /* 662 */
+#define TclDictObjSize \
+ (tclStubsPtr->tclDictObjSize) /* 663 */
+#define TclSplitList \
+ (tclStubsPtr->tclSplitList) /* 664 */
+#define TclSplitPath \
+ (tclStubsPtr->tclSplitPath) /* 665 */
+#define TclFSSplitPath \
+ (tclStubsPtr->tclFSSplitPath) /* 666 */
+#define TclParseArgsObjv \
+ (tclStubsPtr->tclParseArgsObjv) /* 667 */
+#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 */
+#define Tcl_CreateObjCommand2 \
+ (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */
+#define Tcl_CreateObjTrace2 \
+ (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */
+#define Tcl_NRCreateCommand2 \
+ (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */
+#define Tcl_NRCallObjProc2 \
+ (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */
+#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 \
@@ -3971,24 +4194,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))
#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
@@ -3996,9 +4224,6 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_SeekOld
#undef Tcl_TellOld
-#undef TclGetStringFromObj_
-#undef TclGetUnicodeFromObj_
-#undef TclGetByteArrayFromObj_
#undef Tcl_PkgPresent
#define Tcl_PkgPresent(interp, name, version, exact) \
@@ -4015,13 +4240,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)
@@ -4043,6 +4268,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)
@@ -4052,7 +4324,7 @@ extern const TclStubs *tclStubsPtr;
do { \
struct { \
Tcl_Time now; \
- __int64 reserved; \
+ long long reserved; \
} _t; \
_t.reserved = -1; \
tclStubsPtr->tcl_GetTime((&_t.now)); \
@@ -4070,20 +4342,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))Tcl_DbNewWideIntObj)
# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
-# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj)
-# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj)
# define Tcl_ExprLong TclExprLong
static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
int intValue;
@@ -4101,26 +4367,221 @@ extern const TclStubs *tclStubsPtr;
# define Tcl_UniCharNcmp(ucs,uct,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))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
+ ((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
# define Tcl_UtfNcasecmp(s1,s2,n) \
- ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n))
+ ((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n))
# define Tcl_UniCharNcasecmp(ucs,uct,n) \
- ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n))
+ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))(void *)tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n))
# endif
#endif
+#undef Tcl_GetString
+#undef Tcl_GetUnicode
+#define Tcl_GetString(objPtr) \
+ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL)
+#define Tcl_GetUnicode(objPtr) \
+ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL)
+#undef Tcl_GetBytesFromObj
+#undef Tcl_GetIndexFromObjStruct
+#undef Tcl_GetBooleanFromObj
+#undef Tcl_GetBoolean
+#ifdef TCL_NO_DEPRECATED
+#undef Tcl_GetStringFromObj
+#undef Tcl_GetUnicodeFromObj
+#undef Tcl_GetByteArrayFromObj
+#endif
+#if defined(USE_TCL_STUBS)
+#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (sizePtr)))
+#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
+ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
+#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
+ (sizeof(*(boolPtr)) == sizeof(int) ? 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) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
+ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#ifdef TCL_NO_DEPRECATED
+#define Tcl_GetStringFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (sizePtr)))
+#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (sizePtr)))
+#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (sizePtr)))
+#endif
+#else
+#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (sizePtr)))
+#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) ? 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) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
+ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#ifdef TCL_NO_DEPRECATED
+#define Tcl_GetStringFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (sizePtr)))
+#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)(sizePtr)) : TclGetByteArrayFromObj(objPtr, (sizePtr)))
+#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
+ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : TclGetUnicodeFromObj(objPtr, (sizePtr)))
+#endif
+#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)
+#ifdef TCL_NO_DEPRECATED
+# undef Tcl_ListObjGetElements
+# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
+ : tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+# undef Tcl_ListObjLength
+# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \
+ : tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)))
+# undef Tcl_DictObjSize
+# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \
+ : tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)))
+# undef Tcl_SplitList
+# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_SplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
+ : tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)))
+# undef Tcl_SplitPath
+# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_SplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \
+ : tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)))
+# undef Tcl_FSSplitPath
+# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \
+ : tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)))
+# undef Tcl_ParseArgsObjv
+# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
+ : tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)))
+#endif /* TCL_NO_DEPRECATED */
+#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)
+#ifdef TCL_NO_DEPRECATED
+# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? (Tcl_ListObjGetElements)((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \
+ : TclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \
+ ? (Tcl_ListObjLength)((interp), (listPtr), (int *)(void *)(lengthPtr)) \
+ : TclListObjLength((interp), (listPtr), (lengthPtr)))
+# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \
+ ? (Tcl_DictObjSize)((interp), (dictPtr), (int *)(void *)(sizePtr)) \
+ : TclDictObjSize((interp), (dictPtr), (sizePtr)))
+# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? (Tcl_SplitList)((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \
+ : TclSplitList((interp), (listStr), (argcPtr), (argvPtr)))
+# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \
+ ? (Tcl_SplitPath)((path), (int *)(void *)(argcPtr), (argvPtr)) \
+ : TclSplitPath((path), (argcPtr), (argvPtr)))
+# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \
+ ? (Tcl_FSSplitPath)((pathPtr), (int *)(void *)(lenPtr)) \
+ : TclFSSplitPath((pathPtr), (lenPtr)))
+# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \
+ ? (Tcl_ParseArgsObjv)((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \
+ : TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)))
+#endif /* TCL_NO_DEPRECATED */
+#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
+
+/* TIP #660 */
+#define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index f3e8d0c..44ee1a9 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,16 +222,16 @@ typedef struct {
static Tcl_HashEntry *
AllocChainEntry(
- Tcl_HashTable *tablePtr,
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr)
{
- Tcl_Obj *objPtr = keyPtr;
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
ChainEntry *cPtr;
- cPtr = ckalloc(sizeof(ChainEntry));
+ 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(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(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(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 = 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 = ckalloc((unsigned) 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 = ckalloc((unsigned) 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,13 +717,10 @@ 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:
@@ -727,6 +734,23 @@ SetDictFromAny(
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(dictPtr);
if (flags & DICT_PATH_UPDATE) {
dict->chain = 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(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(tmpObj);
+ DictGetInternalRep(tmpObj, newDict);
}
newDict->chain = dictPtr;
@@ -860,17 +890,24 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- 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(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(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(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(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(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(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,11 +1310,12 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetInternalRep(dictPtr, dict);
+ assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
- Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
@@ -1335,7 +1368,8 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetInternalRep(dictPtr, dict);
+ assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1376,14 +1410,12 @@ Tcl_NewDictObj(void)
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
- dict = ckalloc(sizeof(Dict));
+ 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,30 +1447,34 @@ 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;
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
- dict = ckalloc(sizeof(Dict));
+ 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)
@@ -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(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;
+
+ if (objc > 3) {
+ /* Something to append */
- for (i=3 ; i<objc ; i++) {
- Tcl_AppendObjToObj(valuePtr, objv[i]);
+ 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,7 +2485,7 @@ 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) {
@@ -2373,7 +2494,7 @@ DictForNRCmd(
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
- searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
+ searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
@@ -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,15 +2559,15 @@ DictForNRCmd(
static int
DictForLoopCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_DictSearch *searchPtr = data[0];
- Tcl_Obj *keyVarObj = data[1];
- Tcl_Obj *valueVarObj = data[2];
- Tcl_Obj *scriptObj = data[3];
+ Tcl_DictSearch *searchPtr = (Tcl_DictSearch *)data[0];
+ Tcl_Obj *keyVarObj = (Tcl_Obj *)data[1];
+ Tcl_Obj *valueVarObj = (Tcl_Obj *)data[2];
+ Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj *keyObj, *valueObj;
int done;
@@ -2538,7 +2659,7 @@ DictForLoopCallback(
static int
DictMapNRCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2546,7 +2667,8 @@ DictMapNRCmd(
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
- int varc, done;
+ int varc;
+ int done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2558,7 +2680,7 @@ 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) {
@@ -2567,7 +2689,7 @@ DictMapNRCmd(
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
}
- storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
+ storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
&valueObj, &done) != TCL_OK) {
TclStackFree(interp, storagePtr);
@@ -2584,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];
@@ -2642,12 +2764,12 @@ DictMapNRCmd(
static int
DictMapLoopCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- DictMapStorage *storagePtr = data[0];
+ DictMapStorage *storagePtr = (DictMapStorage *)data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
@@ -2750,7 +2872,7 @@ DictMapLoopCallback(
static int
DictSetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2810,7 +2932,7 @@ DictSetCmd(
static int
DictUnsetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2869,7 +2991,7 @@ DictUnsetCmd(
static int
DictFilterCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2884,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) {
@@ -2997,7 +3120,7 @@ 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) {
@@ -3154,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,
@@ -3184,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);
@@ -3208,15 +3332,15 @@ DictUpdateCmd(
static int
FinalizeDictUpdate(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *dictPtr, *objPtr, **objv;
Tcl_InterpState state;
int i, objc;
- Tcl_Obj *varName = data[0];
- Tcl_Obj *argsObj = data[1];
+ Tcl_Obj *varName = (Tcl_Obj *)data[0];
+ Tcl_Obj *argsObj = (Tcl_Obj *)data[1];
/*
* ErrorInfo handling.
@@ -3258,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) {
@@ -3312,7 +3436,7 @@ FinalizeDictUpdate(
static int
DictWithCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -3359,16 +3483,16 @@ DictWithCmd(
static int
FinalizeDictWith(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
int pathc;
Tcl_InterpState state;
- Tcl_Obj *varName = data[0];
- Tcl_Obj *keysPtr = data[1];
- Tcl_Obj *pathPtr = data[2];
+ Tcl_Obj *varName = (Tcl_Obj *)data[0];
+ Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
+ Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
Var *varPtr, *arrayPtr;
if (result == TCL_ERROR) {
@@ -3382,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;
@@ -3588,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 4cae594..72c5bc8 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,10 +21,8 @@
* 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,
@@ -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);
@@ -191,7 +198,7 @@ TclPrintObject(
char *bytes;
int length;
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
@@ -242,20 +249,22 @@ 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;
+ 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,19 +276,17 @@ 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,
+ "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %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",
@@ -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 %d+litObj %"
+ TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\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 */
@@ -314,10 +322,9 @@ DisassembleByteCodeObj(
Proc *procPtr = codePtr->procPtr;
int 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 %u, args %d, compiled locals %d\n",
+ procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
@@ -648,7 +655,7 @@ FormatInstruction(
int 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);
@@ -758,7 +765,7 @@ TclGetInnerContext(
* 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));
@@ -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 = ckalloc(len + 1);
- memcpy(objPtr->bytes, s, len + 1);
- objPtr->length = len;
}
/*
@@ -929,17 +937,17 @@ 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;
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+
/*
* Get the literals from the bytecode.
*/
@@ -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;
}
@@ -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(Tcl_NumUtfChars(codePtr->source,
sourceOffset)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
- Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+ Tcl_NewWideIntObj(Tcl_NumUtfChars(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 = 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 = objv[2]->internalRep.twoPtrValue.ptr1;
+
+ procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr);
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
memset(&cmd, 0, sizeof(Command));
- nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
@@ -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];
@@ -1418,7 +1420,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1483,7 +1485,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1560,7 +1562,7 @@ Tcl_DisassembleObjCmd(
TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
@@ -1568,7 +1570,7 @@ Tcl_DisassembleObjCmd(
"METHODTYPE", 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);
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 dea112a..32878b0 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -3,7 +3,7 @@
*
* 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.
@@ -33,20 +33,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;
@@ -185,6 +187,29 @@ static Tcl_Encoding systemEncoding = NULL;
Tcl_Encoding tclIdentityEncoding = NULL;
/*
+ * Names of encoding profiles and corresponding integer values.
+ * Keep alphabetical order for error messages.
+ */
+static 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_) \
+ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT)
+
+#define PROFILE_REPLACE(flags_) \
+ (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE)
+
+#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
* TableEncoding to represent a page in the table that has no entries.
*/
@@ -214,51 +239,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 +260,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 +308,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 +337,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 +358,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 +397,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 +444,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 +480,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 +509,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 +544,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 +566,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 +586,7 @@ TclInitEncodingSubsystem(void)
* properly formed stream.
*/
- type.encodingName = "identity";
+ type.encodingName = NULL;
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
@@ -565,20 +595,62 @@ 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);
+ 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.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.clientData = INT2PTR(isLe.c);
+ 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
@@ -686,13 +758,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 +796,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 +908,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 +992,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 +1022,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 +1133,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 +1163,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 +1203,102 @@ 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}
+ * - TCL_ENCODING_STOPONERROR: Backward compatibility. Sets the profile
+ * to TCL_ENCODING_PROFILE_STRICT overriding any specified profile flags
+ * Any other flag bits will cause an error to be returned (for future
+ * compatibility)
+ *
+ * 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", NULL);
+ 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 +1306,48 @@ 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), "%u", nBytesProcessed);
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("unexpected byte sequence starting at index %"
+ "u: '\\x%02X'",
+ nBytesProcessed,
+ UCHAR(srcStart[nBytesProcessed])));
+ Tcl_SetErrorCode(
+ interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL);
+ }
+ }
+ 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 +1378,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 +1392,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
@@ -1233,21 +1441,24 @@ Tcl_ExternalToUtf(
}
if (!noTerminate) {
- if (dstLen < 1) {
- return TCL_CONVERT_NOSPACE;
- }
+ if (dstLen < 1) {
+ return TCL_CONVERT_NOSPACE;
+ }
/*
* 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...
*/
dstLen--;
} else {
- if (dstLen < 0) {
- return TCL_CONVERT_NOSPACE;
- }
+ if (dstLen < 0) {
+ return TCL_CONVERT_NOSPACE;
+ }
+ }
+ if (encodingPtr->toUtfProc == UtfToUtfProc) {
+ flags |= ENCODING_INPUT;
}
do {
Tcl_EncodingState savedState = *statePtr;
@@ -1258,7 +1469,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 +1506,92 @@ 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{DEFAULT,TCL8,STRICT}
+ * - TCL_ENCODING_STOPONERROR: Backward compatibility. Sets the profile
+ * to TCL_ENCODING_PROFILE_STRICT overriding any specified profile flags
+ *
+ * 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", NULL);
+ return TCL_ERROR;
+ }
+
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
@@ -1319,23 +1605,49 @@ 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) {
+ int pos = Tcl_NumUtfChars(srcStart, nBytesProcessed);
+ int ucs4;
+ char buf[TCL_INTEGER_SPACE];
+ TclUtfToUCS4(&srcStart[nBytesProcessed], &ucs4);
+ snprintf(buf, sizeof(buf), "%u", nBytesProcessed);
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf(
+ "unexpected character at index %d: 'U+%06X'",
+ pos,
+ ucs4));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
+ buf, NULL);
+ }
+ }
+ return result;
}
flags &= ~TCL_ENCODING_START;
- src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
@@ -1366,11 +1678,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 +1692,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
@@ -1423,20 +1735,17 @@ Tcl_UtfToExternal(
}
if (dstLen < encodingPtr->nullSize) {
- return TCL_CONVERT_NOSPACE;
+ return TCL_CONVERT_NOSPACE;
}
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 +1768,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 +1804,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);
@@ -1723,7 +2033,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 +2075,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 +2159,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 +2311,7 @@ LoadEscapeEncoding(
Tcl_DStringInit(&escapeData);
while (1) {
- int argc;
+ Tcl_Size argc;
const char **argv;
char *line;
Tcl_DString lineString;
@@ -2053,7 +2363,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 +2421,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
@@ -2140,6 +2446,7 @@ BinaryProc(
if (dstLen < 0) {
dstLen = 0;
}
+ flags = TclEncodingSetProfileFlags(flags);
if ((flags & TCL_ENCODING_CHAR_LIMIT) && srcLen > *dstCharsPtr) {
srcLen = *dstCharsPtr;
}
@@ -2158,11 +2465,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 +2481,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 +2503,195 @@ 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;
+ flags = TclEncodingSetProfileFlags(flags);
+ 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 TclUtfToUCS4. 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;
+ TclUtfToUCS4(chbuf, &ch);
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ } else {
+ int low;
+ int isInvalid = 0;
+ size_t len = TclUtfToUCS4(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) ? TclUtfToUCS4(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 +2703,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 +2725,128 @@ 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 = TclEncodingSetProfileFlags(flags);
+ 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 +2858,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 +2876,28 @@ 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;
+ flags = TclEncodingSetProfileFlags(flags);
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 +2911,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;
+ len = TclUtfToUCS4(src, &ch);
+ if (SURROGATE(ch)) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_UNKNOWN;
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;
- break;
+ if (PROFILE_REPLACE(flags)) {
+ ch = UNICODE_REPLACE_CHAR;
}
- 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;
- }
-#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 +2944,7 @@ UtfToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UnicodeToUtfProc --
+ * Utf16ToUtfProc --
*
* Convert from UTF-16 to UTF-8.
*
@@ -2435,16 +2958,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 +2983,10 @@ UnicodeToUtfProc(
const char *srcStart, *srcEnd;
const char *dstEnd, *dstStart;
int result, numChars, charLimit = INT_MAX;
- unsigned short ch;
+ unsigned short ch = 0;
+ flags = TclEncodingSetProfileFlags(flags);
+ flags |= PTR2INT(clientData);
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
@@ -2480,18 +3001,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 +3024,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 +3103,7 @@ UnicodeToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UtfToUnicodeProc --
+ * UtfToUtf16Proc --
*
* Convert from UTF-8 to UTF-16.
*
@@ -2559,16 +3117,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,20 +3141,19 @@ 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;
+ flags = TclEncodingSetProfileFlags(flags);
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
+ flags |= PTR2INT(clientData);
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
@@ -2617,38 +3170,154 @@ 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 = TclUtfToUCS4(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);
}
+ }
+ }
+ *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 = TclEncodingSetProfileFlags(flags);
+ 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 - sizeof(Tcl_UniChar);
+
+ 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;
+ }
+#if TCL_UTF_MAX < 4
+ len = TclUtfToUniChar(src, &ch);
+ if ((ch >= 0xD800) && (len < 3)) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ src += len;
+ src += TclUtfToUniChar(src, &ch);
+ ch = UNICODE_REPLACE_CHAR;
+ }
#else
- *dst++ = (*chPtr >> 8);
- *dst++ = (*chPtr & 0xFF);
+ len = TclUtfToUniChar(src, &ch);
+ if (ch > 0xFFFF) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ ch = UNICODE_REPLACE_CHAR;
+ }
#endif
+ 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 +3345,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
@@ -2710,6 +3375,7 @@ TableToUtfProc(
const unsigned short *pageZero;
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
+ flags = TclEncodingSetProfileFlags(flags);
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
@@ -2733,30 +3399,47 @@ TableToUtfProc(
if (prefixBytes[byte]) {
src++;
if (src >= srcEnd) {
- src--;
- result = TCL_CONVERT_MULTIBYTE;
- break;
+ if (!(flags & TCL_ENCODING_END)) {
+ src--;
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ } else if (PROFILE_STRICT(flags)) {
+ src--;
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ } else if (PROFILE_REPLACE(flags)) {
+ ch = UNICODE_REPLACE_CHAR;
+ } else {
+ src--; /* See bug [bdcb5126c0] */
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ } else {
+ ch = toUnicode[byte][*((unsigned char *)src)];
}
- ch = toUnicode[byte][*((unsigned char *) src)];
} else {
ch = pageZero[byte];
}
if ((ch == 0) && (byte != 0)) {
- 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;
+ }
}
/*
* Special case for 1-byte Utf chars for speed.
*/
- if (ch && ch < 0x80) {
+ if ((unsigned)ch - 1 < 0x7F) {
*dst++ = (char) ch;
} else {
dst += Tcl_UniCharToUtf(ch, dst);
@@ -2789,16 +3472,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
@@ -2830,6 +3509,7 @@ TableFromUtfProc(
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
+ flags = TclEncodingSetProfileFlags(flags);
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
@@ -2849,12 +3529,12 @@ TableFromUtfProc(
}
len = TclUtfToUniChar(src, &ch);
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
/* Unicode chars > +U0FFFF cannot be represented in any table encoding */
if (ch & 0xFFFF0000) {
word = 0;
} else
-#elif TCL_UTF_MAX == 4
+#else
if (!len) {
word = 0;
} else
@@ -2862,11 +3542,11 @@ TableFromUtfProc(
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) {
@@ -2911,15 +3591,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
@@ -2940,6 +3616,7 @@ Iso88591ToUtfProc(
const char *dstEnd, *dstStart;
int result, numChars, charLimit = INT_MAX;
+ flags = TclEncodingSetProfileFlags(flags);
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
@@ -2963,7 +3640,7 @@ Iso88591ToUtfProc(
* Special case for 1-byte utf chars for speed.
*/
- if (ch && ch < 0x80) {
+ if ((unsigned)ch - 1 < 0x7F) {
*dst++ = (char) ch;
} else {
dst += Tcl_UniCharToUtf(ch, dst);
@@ -2995,15 +3672,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
@@ -3028,6 +3701,7 @@ Iso88591FromUtfProc(
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
+ flags = TclEncodingSetProfileFlags(flags);
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
@@ -3054,15 +3728,15 @@ Iso88591FromUtfProc(
*/
if (ch > 0xFF
-#if TCL_UTF_MAX == 4
+#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 TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (len < 3)) {
len = 4;
}
@@ -3071,7 +3745,7 @@ Iso88591FromUtfProc(
* Plunge on, using '?' as a fallback character.
*/
- ch = (Tcl_UniChar) '?';
+ ch = (Tcl_UniChar) '?'; /* Profiles TCL8 and REPLACE */
}
if (dst > dstEnd) {
@@ -3107,10 +3781,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]
@@ -3142,7 +3816,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. */
@@ -3168,13 +3842,14 @@ 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;
int state, result, numChars, charLimit = INT_MAX;
const char *dstStart, *dstEnd;
+ flags = TclEncodingSetProfileFlags(flags);
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
@@ -3285,9 +3960,10 @@ EscapeToUtfProc(
if ((checked == dataPtr->numSubTables + 2)
|| (flags & TCL_ENCODING_END)) {
- if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
+ if (!PROFILE_STRICT(flags)) {
/*
- * Skip the unknown escape sequence.
+ * Skip the unknown escape sequence. TODO - bug?
+ * May be replace with UNICODE_REPLACE_CHAR?
*/
src += longest;
@@ -3356,7 +4032,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. */
@@ -3397,6 +4073,7 @@ EscapeFromUtfProc(
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
+ flags = TclEncodingSetProfileFlags(flags);
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
@@ -3460,7 +4137,7 @@ EscapeFromUtfProc(
if (word == 0) {
state = oldState;
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
@@ -3493,8 +4170,7 @@ EscapeFromUtfProc(
result = TCL_CONVERT_NOSPACE;
break;
}
- memcpy(dst, subTablePtr->sequence,
- subTablePtr->sequenceLen);
+ memcpy(dst, subTablePtr->sequence, subTablePtr->sequenceLen);
dst += subTablePtr->sequenceLen;
}
}
@@ -3568,7 +4244,7 @@ EscapeFromUtfProc(
static void
EscapeFreeProc(
- ClientData clientData) /* EscapeEncodingData that specifies
+ void *clientData) /* EscapeEncodingData that specifies
* encoding. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
@@ -3645,7 +4321,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
@@ -3672,6 +4348,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;
+}
/*
*-------------------------------------------------------------------------
@@ -3699,11 +4388,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");
@@ -3712,7 +4401,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;
@@ -3733,7 +4422,7 @@ InitializeEncodingSearchPath(
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
- bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
+ bytes = TclGetStringFromObj(searchPathObj, &numBytes);
*lengthPtr = numBytes;
*valuePtr = (char *)ckalloc(numBytes + 1);
@@ -3742,6 +4431,166 @@ 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, ",", NULL);
+ }
+ Tcl_AppendStringsToObj(
+ errorObj, " or ", encodingProfiles[numProfiles-1].name, NULL);
+
+ Tcl_SetObjResult(interp, errorObj);
+ Tcl_SetErrorCode(
+ interp, "TCL", "ENCODING", "PROFILE", profileName, 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", NULL);
+ }
+ return NULL;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclEncodingSetProfileFlags --
+ *
+ * Maps the flags supported in the encoding C API's to internal flags.
+ *
+ * For backward compatibility reasons, TCL_ENCODING_STOPONERROR is
+ * is mapped to the TCL_ENCODING_PROFILE_STRICT overwriting any profile
+ * specified.
+ *
+ * If no profile or an invalid profile is specified, it is set to
+ * the default.
+ *
+ * Results:
+ * Internal encoding flag mask.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+int TclEncodingSetProfileFlags(int flags)
+{
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_STRICT);
+ } else {
+ int profile = ENCODING_PROFILE_GET(flags);
+ switch (profile) {
+ case TCL_ENCODING_PROFILE_TCL8:
+ case TCL_ENCODING_PROFILE_STRICT:
+ case TCL_ENCODING_PROFILE_REPLACE:
+ break;
+ case 0: /* Unspecified by caller */
+ default:
+ ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_TCL8);
+ break;
+ }
+ }
+ return flags;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * 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 b00aa7d..2a33398 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,9 +84,24 @@ 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 {
@@ -98,10 +111,9 @@ typedef struct {
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,21 +151,22 @@ 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",
@@ -176,7 +188,8 @@ TclNamespaceEnsembleCmd(
switch ((enum EnsSubcmds) index) {
case ENS_CREATE: {
const char *name;
- int len, allocatedMapFlag = 0;
+ int 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) {
@@ -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;
+ int 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);
@@ -567,6 +582,14 @@ TclNamespaceEnsembleCmd(
}
goto freeMapAndError;
}
+ if (TclListObjGetElementsM(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
@@ -576,7 +599,8 @@ TclNamespaceEnsembleCmd(
Tcl_AppendStringsToObj(newCmd, "::", 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]);
}
@@ -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,24 +674,22 @@ 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;
Tcl_Command token;
- ensemblePtr = ckalloc(sizeof(EnsembleConfig));
+ 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,7 +792,7 @@ 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);
@@ -783,7 +801,7 @@ Tcl_SetEnsembleSubcommandList(
if (subcmdList != NULL) {
int length;
- if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -791,7 +809,7 @@ Tcl_SetEnsembleSubcommandList(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
@@ -850,7 +868,7 @@ Tcl_SetEnsembleParameterList(
Tcl_Obj *oldList;
int 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);
@@ -859,7 +877,7 @@ Tcl_SetEnsembleParameterList(
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) {
@@ -867,7 +885,7 @@ Tcl_SetEnsembleParameterList(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->parameterList;
ensemblePtr->parameterList = paramList;
if (paramList != NULL) {
@@ -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);
return TCL_ERROR;
}
if (mapDict != NULL) {
- int size, done;
+ int size;
+ int done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
@@ -967,7 +986,7 @@ Tcl_SetEnsembleMappingDict(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
@@ -1025,7 +1044,7 @@ 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);
@@ -1034,7 +1053,7 @@ Tcl_SetEnsembleUnknownHandler(
if (unknownList != NULL) {
int length;
- if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -1042,7 +1061,7 @@ Tcl_SetEnsembleUnknownHandler(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
@@ -1091,14 +1110,14 @@ 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);
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
/*
@@ -1167,7 +1186,7 @@ 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));
@@ -1176,7 +1195,7 @@ Tcl_GetEnsembleSubcommandList(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
@@ -1209,7 +1228,7 @@ 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));
@@ -1218,7 +1237,7 @@ Tcl_GetEnsembleParameterList(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
}
@@ -1251,7 +1270,7 @@ 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));
@@ -1260,7 +1279,7 @@ Tcl_GetEnsembleMappingDict(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
@@ -1292,7 +1311,7 @@ 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));
@@ -1301,7 +1320,7 @@ Tcl_GetEnsembleUnknownHandler(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
@@ -1333,7 +1352,7 @@ 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));
@@ -1342,7 +1361,7 @@ Tcl_GetEnsembleFlags(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
@@ -1374,7 +1393,7 @@ 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));
@@ -1383,7 +1402,7 @@ Tcl_GetEnsembleNamespace(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
@@ -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,7 +1451,8 @@ 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",
@@ -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;
+ int i, nameCount = 0;
+ int ensembleFlags = 0, hiddenLen;
/*
* Construct the path for the ensemble namespace and create it.
@@ -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,12 +1698,12 @@ NsEnsembleImplementationCmd(
static int
NsEnsembleImplementationCmdNR(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- EnsembleConfig *ensemblePtr = clientData;
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
/* The ensemble itself. */
Tcl_Obj *prefixObj; /* An object containing the prefix words of
* the command that implements the
@@ -1696,7 +1717,7 @@ NsEnsembleImplementationCmdNR(
int 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.
*/
@@ -1736,26 +1757,24 @@ NsEnsembleImplementationCmdNR(
}
/*
- * 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 = subObj->internalRep.twoPtrValue.ptr1;
-
+ ECRGetInternalRep(subObj, ensembleCmd);
+ if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
- prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
+ prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
if (ensembleCmd->fix) {
TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
@@ -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_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;
@@ -1858,31 +1875,29 @@ NsEnsembleImplementationCmdNR(
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
- prefixObj = Tcl_GetHashValue(hPtr);
+ prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_IncrRefCount(prefixObj);
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;
- 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,10 +1956,10 @@ 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);
@@ -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
@@ -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];
@@ -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;
@@ -2168,9 +2182,9 @@ TclSpellFix(
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
- Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
+ Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
- store = ckalloc(size * sizeof(Tcl_Obj *));
+ store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *));
memcpy(store, iPtr->ensembleRewrite.sourceObjs,
size * sizeof(Tcl_Obj *));
@@ -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,28 @@ EnsembleUnknownCallback(
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
- int paramc, i, result, prefixObjc;
+ int paramc, i, prefixObjc;
+ int result;
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);
@@ -2316,10 +2330,9 @@ EnsembleUnknownCallback(
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 +2341,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 +2354,7 @@ EnsembleUnknownCallback(
}
/*
- * Namespace alive & empty result => reparse.
+ * Empty result => reparse.
*/
TclDecrRefCount(*prefixObjPtr);
@@ -2353,7 +2362,7 @@ EnsembleUnknownCallback(
}
/*
- * Oh no! An exceptional result. Convert to an error.
+ * Convert exceptional result to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
@@ -2393,16 +2402,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 +2425,19 @@ MakeCachedEnsembleCommand(
{
EnsembleCmdRep *ensembleCmd;
- if (objPtr->typePtr == &ensembleCmdType) {
- ensembleCmd = 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 = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
- objPtr->typePtr = &ensembleCmdType;
+ ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
+ ECRSetInternalRep(objPtr, ensembleCmd);
}
/*
@@ -2453,17 +2459,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.
*
*----------------------------------------------------------------------
*/
@@ -2479,7 +2484,7 @@ ClearTable(
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
@@ -2490,15 +2495,12 @@ ClearTable(
static void
DeleteEnsembleConfig(
- ClientData clientData)
+ void *clientData)
{
- EnsembleConfig *ensemblePtr = 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 +2526,7 @@ DeleteEnsembleConfig(
ensemblePtr->flags |= ENSEMBLE_DEAD;
/*
- * Kill the pointer-containing fields.
+ * Release the fields that contain pointers.
*/
ClearTable(ensemblePtr);
@@ -2542,10 +2544,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 +2557,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 +2569,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 +2578,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. */
+ int i, j;
+ int isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
@@ -2591,17 +2593,17 @@ BuildEnsembleConfig(
if (subList) {
int 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 +2627,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 +2638,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 +2652,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 +2666,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 +2678,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 +2687,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 = /* Name of command in namespace. */
- Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
+ (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
@@ -2735,22 +2740,22 @@ BuildEnsembleConfig(
/*
* 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 =
- ckalloc(sizeof(char *) * hash->numEntries);
+ (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,27 +2763,27 @@ 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;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
- ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
+ ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
if (hPtr == NULL) {
break;
}
- ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
+ ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
}
if (hash->numEntries > 1) {
- qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries,
+ qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
sizeof(char *), NsEnsembleStringOrder);
}
}
@@ -2788,8 +2793,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 +2836,14 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = 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 +2869,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
- EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
+ EnsembleCmdRep *ensembleCmd;
+ EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
+
+ ECRGetInternalRep(objPtr, ensembleCmd);
+ ECRSetInternalRep(copyPtr, ensembleCopy);
- copyPtr->typePtr = &ensembleCmdType;
- copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
@@ -2916,14 +2921,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;
+ int 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) {
@@ -2992,11 +2998,11 @@ TclCompileEnsemble(
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!
@@ -3112,7 +3118,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 +3172,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 +3189,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;
@@ -3250,10 +3256,11 @@ TclAttemptCompileProc(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
- int result, i;
+ int result;
+ int i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
- unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
+ TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
@@ -3266,9 +3273,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 +3392,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;
+ int i, numWords, length;
/*
* Push the words of the command. Take care; the command words may be
@@ -3394,19 +3402,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 +3435,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 e9f7d7d..e9da69f 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(tenvstr, len, dstr) \
- Tcl_WinTCharToUtf((TCHAR *)tenvstr, len, dstr)
-# define utf2tenvirondstr(str, len, dstr) \
- (const WCHAR *)Tcl_WinUtfToTChar(str, len, dstr)
+# define tenviron2utfdstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
+# define utf2tenvirondstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (const WCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
@@ -624,10 +624,9 @@ TclGetEnv(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static char *
EnvTraceProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 35136e1..56004aa 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;
@@ -100,22 +114,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 +156,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 +165,7 @@ Tcl_BackgroundError(
{
Tcl_BackgroundException(interp, TCL_ERROR);
}
+#endif /* TCL_NO_DEPRECATED */
void
Tcl_BackgroundException(
@@ -198,7 +218,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;
@@ -226,7 +246,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;
@@ -308,7 +328,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. */
@@ -593,8 +613,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 +652,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 +685,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 +718,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 +761,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 +804,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 +837,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 +1019,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 +1033,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 +1043,91 @@ 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) && !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
+#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
+#if TCL_UTF_MAX < 4
+ ".utf-16"
+#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 +1150,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 +1328,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 +1498,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", 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", 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", 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", 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", 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", 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_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", NULL);
- return TCL_ERROR;
+ 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,7 +1951,7 @@ 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. */
@@ -1517,7 +1970,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 +2000,7 @@ Tcl_UpdateObjCmd(
return TCL_OK;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1566,10 +2019,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 +2058,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() */
+ void *clientData, /* The one argument to Main() */
int 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 44ace68..e3b85b4 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 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002-2010 by Miguel Sofer.
- * Copyright (c) 2005-2007 by Donal K. Fellows.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
- * Copyright (c) 2006-2008 by 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,8 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
+#include "tclArithSeries.h"
#include <math.h>
#include <assert.h>
@@ -34,14 +35,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 +98,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 +167,14 @@ 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 **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 *stack[1]; /* Start of the actual combined catch and obj
* stacks; the struct will be expanded as
* necessary */
} TEBCdata;
@@ -202,7 +203,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 +212,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 +425,7 @@ VarHashCreateVar(
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
-#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
+#define CURR_DEPTH ((size_t)(tosPtr - initTosPtr))
#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
@@ -437,9 +438,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, "%2d: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
+ CURR_DEPTH, \
+ (size_t)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
@@ -453,9 +454,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, "%2d: %2" TCL_Z_MODIFIER "u (%" TCL_Z_MODIFIER "u) %s ", iPtr->numLevels, \
+ CURR_DEPTH, \
+ (size_t)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
@@ -502,61 +503,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 +552,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 +655,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 +663,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);
@@ -830,20 +758,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 = objPtr->internalRep.twoPtrValue.ptr1;
+ searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree(searchPtr);
- dictPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
-
- objPtr->typePtr = NULL;
}
/*
@@ -867,6 +797,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 +805,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 +814,15 @@ InitByteCodeExecution(
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
#endif /* TCL_COMPILE_STATS */
}
+
+#else
+
+static void
+InitByteCodeExecution(
+ TCL_UNUSED(Tcl_Interp *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -913,14 +853,14 @@ TclCreateExecEnv(
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
- ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
- ExecStack *esPtr = ckalloc(TclOffset(ExecStack, stackWords)
+ ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
+ 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;
@@ -1180,10 +1120,10 @@ GrowEvaluationStack(
newElems = needed;
#endif
- newBytes = TclOffset(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
+ newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
oldPtr = esPtr;
- esPtr = ckalloc(newBytes);
+ esPtr = (ExecStack *)ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
@@ -1282,7 +1222,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- ckfree((char *) freePtr);
+ ckfree(freePtr);
return;
}
@@ -1407,7 +1347,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,12 +1364,12 @@ Tcl_ExprObj(
static int
CopyCallback(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- Tcl_Obj **resultPtrPtr = data[0];
- Tcl_Obj *resultPtr = data[1];
+ Tcl_Obj **resultPtrPtr = (Tcl_Obj **)data[0];
+ Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
*resultPtrPtr = resultPtr;
@@ -1482,12 +1422,12 @@ Tcl_NRExprObj(
static int
ExprObjCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
- Tcl_InterpState state = data[0];
- Tcl_Obj *resultPtr = data[1];
+ Tcl_InterpState state = (Tcl_InterpState)data[0];
+ Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
@@ -1506,11 +1446,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,19 +1472,23 @@ 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 = 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.
*/
@@ -1563,7 +1505,7 @@ CompileExprObj(
*/
if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0),
&compEnv);
}
@@ -1574,10 +1516,8 @@ CompileExprObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &exprCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1621,8 +1561,8 @@ CompileExprObj(
static void
DupExprCodeInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj *))
{
return;
}
@@ -1649,12 +1589,11 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = 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 +1629,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 +1648,6 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1775,9 +1714,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 +1775,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 +1809,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 +1835,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 +1852,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 +1864,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;
}
@@ -2024,8 +1934,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
@@ -2040,7 +1950,7 @@ TclNRExecuteByteCode(
* sizeof(void *);
int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- codePtr->refCount++;
+ TclPreserveByteCode(codePtr);
/*
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
@@ -2096,7 +2006,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 +2019,7 @@ TclNRExecuteByteCode(
static int
TEBCresume(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2136,8 +2046,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 +2071,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 +2083,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 +2105,8 @@ TEBCresume(
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
- int objc = 0;
- int opnd, length, pcAdjustment;
+ int length, objc = 0;
+ int opnd, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
@@ -2206,7 +2122,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_Z_MODIFIER "u\n", CURR_DEPTH);
fflush(stdout);
}
#endif
@@ -2357,10 +2273,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 +2326,7 @@ TEBCresume(
CHECK_STACK();
if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
+ fprintf(stdout, "%2d: %2" TCL_Z_MODIFIER "u ", iPtr->numLevels, CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
@@ -2508,7 +2425,7 @@ TEBCresume(
{
CoroutineData *corPtr;
- int yieldParameter;
+ void *yieldParameter;
case INST_YIELD:
corPtr = iPtr->execEnvPtr->corPtr;
@@ -2529,14 +2446,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, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n",
+ iPtr->numLevels, (size_t)(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;
@@ -2572,9 +2489,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, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
+ TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2586,11 +2503,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 +2526,7 @@ TEBCresume(
cleanup = 1;
TEBC_YIELD();
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
- INT2PTR(yieldParameter), NULL, NULL);
+ yieldParameter, NULL, NULL);
return TCL_OK;
}
@@ -2734,154 +2652,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 +2676,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:
/*
@@ -2909,10 +2693,10 @@ TEBCresume(
*/
TclNewObj(objPtr);
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
+ objPtr->internalRep.twoPtrValue.ptr2 = UINT2PTR(CURR_DEPTH);
objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
- TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
+ TRACE(("=> mark depth as %" TCL_Z_MODIFIER "u\n", CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
break;
@@ -2924,7 +2708,7 @@ TEBCresume(
*/
CLANG_ASSERT(auxObjList);
- objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
+ objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
/* Ugly abuse! */
@@ -2935,7 +2719,8 @@ TEBCresume(
case INST_EXPAND_STKTOP: {
int i;
- ptrdiff_t moved;
+ TEBCdata *newTD;
+ ptrdiff_t oldCatchTopOff, oldTosPtrOff;
/*
* Make sure that the element at stackTop is a list; if not, just
@@ -2945,7 +2730,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 +2749,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;
}
}
@@ -3028,7 +2815,7 @@ TEBCresume(
case INST_INVOKE_EXPANDED:
CLANG_ASSERT(auxObjList);
- objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
+ objc = CURR_DEPTH - PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
@@ -3064,8 +2851,8 @@ TEBCresume(
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%u => call ", objc));
} else {
- fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels,
+ (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -3197,8 +2984,8 @@ TEBCresume(
TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr)));
} else {
fprintf(stdout,
- "%d: (%u) invoking (using implementation %s) ",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart),
O2S(objPtr));
}
for (i = 0; i < objc; i++) {
@@ -3240,7 +3027,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 +3187,8 @@ TEBCresume(
*/
{
- int storeFlags, len;
+ int storeFlags;
+ int len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3651,7 +3439,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 +3465,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 +3507,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 +3518,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 +3528,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 +3566,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 +3576,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 +3585,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 +3612,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
-#endif
long increment;
case INST_INCR_SCALAR1:
@@ -3922,14 +3706,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,22 +3725,21 @@ 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 {
@@ -3967,44 +3750,10 @@ TEBCresume(
* 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 +3763,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 +3777,7 @@ TEBCresume(
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
@@ -4039,7 +3788,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)) {
@@ -4413,10 +4162,7 @@ TEBCresume(
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 +4306,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 +4356,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 +4365,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 +4390,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 +4467,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);
}
@@ -4781,6 +4527,18 @@ 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();
@@ -4790,12 +4548,6 @@ TEBCresume(
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);
}
@@ -4824,7 +4576,7 @@ TEBCresume(
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.
@@ -4852,7 +4604,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
if (oPtr == NULL) {
@@ -4884,9 +4636,9 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
- fprintf(stdout, "%d: (%u) invoking ",
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) 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 +4662,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) {
@@ -4951,7 +4703,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
@@ -4986,8 +4738,8 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
- fprintf(stdout, "%d: (%u) invoking ",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
+ fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -5037,7 +4789,11 @@ TEBCresume(
Method *const mPtr =
contextPtr->callPtr->chain[newDepth].mPtr;
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, opnd, objv);
}
@@ -5079,8 +4835,8 @@ TEBCresume(
*/
{
- int index, numIndices, fromIdx, toIdx;
- int nocase, match, length2, cflags, s1len, s2len;
+ int numIndices, nocase, match, cflags;
+ int length2, fromIdx, toIdx, index, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
@@ -5096,7 +4852,7 @@ 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;
}
@@ -5109,21 +4865,48 @@ 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);
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
+
+ lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
@@ -5147,12 +4930,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 +4975,8 @@ TEBCresume(
TclNewObj(objResultPtr);
}
+ lindexFastPath2:
+
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
@@ -5287,11 +5095,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 +5127,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) {
@@ -5340,36 +5142,24 @@ TEBCresume(
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,7 +5172,7 @@ 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;
}
@@ -5390,13 +5180,17 @@ TEBCresume(
if (length > 0) {
int 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 +5200,9 @@ TEBCresume(
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
+ if (isArithSeries) {
+ TclDecrRefCount(o);
+ }
i++;
} while (i < length && match == 0);
}
@@ -5447,15 +5244,107 @@ TEBCresume(
NEXT_INST_F(1, 1, 0);
}
- /*
- * End of INST_LIST and related instructions.
- * -----------------------------------------------------------------
- * Start of string-related instructions.
- */
+ case INST_LREPLACE4:
+ {
+ int numToDelete, numNewElems, 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 = toIdx - fromIdx + 1;
+ }
+ }
+
+ 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 +5375,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,7 +5399,7 @@ 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));
NEXT_INST_F(1, 1, 1);
@@ -5524,7 +5417,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 +5434,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 +5451,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,26 +5465,41 @@ 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);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
- Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
+ TclGetByteArrayFromObj(valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && length == valuePtr->length) {
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 +5508,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 +5537,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,50 +5549,28 @@ 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);
@@ -5695,17 +5583,20 @@ TEBCresume(
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);
@@ -5734,82 +5625,9 @@ TEBCresume(
NEXT_INST_F(1, 0, 0);
}
- length3 = Tcl_GetCharLength(value3Ptr);
+ objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
+ toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);
- /*
- * 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 = 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 +5650,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,9 +5667,9 @@ 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++) {
@@ -5861,14 +5679,14 @@ TEBCresume(
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 +5694,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 +5702,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;
- }
- }
- }
+ objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
- 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_CLASS:
@@ -5930,7 +5720,7 @@ 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;
@@ -5957,12 +5747,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) {
@@ -6090,38 +5880,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 +5931,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 +6010,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 +6029,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,26 +6039,26 @@ 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
@@ -6304,7 +6069,7 @@ TEBCresume(
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,7 +6079,7 @@ TEBCresume(
* Quickly force large right shifts to 0 or -1.
*/
- if (l2 >= (long)(CHAR_BIT*sizeof(long))) {
+ if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) {
/*
* We assume that INT_MAX is much larger than the
* number of bits in a long. This is a pretty safe
@@ -6323,7 +6088,7 @@ TEBCresume(
*/
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (l1 > 0L) {
+ if (w1 > 0L) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
@@ -6336,13 +6101,13 @@ TEBCresume(
* Handle shifts within the native long 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
@@ -6353,12 +6118,12 @@ TEBCresume(
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
@@ -6376,17 +6141,17 @@ TEBCresume(
#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.
*/
- if (((size_t) shift < CHAR_BIT*sizeof(long))
- && !((l1>0 ? l1 : ~l1) &
+ if (((size_t)shift < CHAR_BIT*sizeof(long))
+ && !((w1>0 ? w1 : ~w1) &
-(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
- lResult = (unsigned long)l1 << shift;
- goto longResultOfArithmetic;
+ wResult = (Tcl_WideUInt)w1 << shift;
+ goto wideResultOfArithmetic;
}
}
@@ -6398,23 +6163,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;
}
}
@@ -6497,18 +6253,13 @@ TEBCresume(
* 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 +6267,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 +6284,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 +6352,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 +6400,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 +6438,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 +6555,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 +6592,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 +6604,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 +6638,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 +6647,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 +6663,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++;
@@ -6941,7 +6691,7 @@ TEBCresume(
listVarPtr = LOCAL(listTmpIndex);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
- TclListObjGetElements(interp, listPtr, &listLen, &elements);
+ TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -6984,7 +6734,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 +6755,9 @@ TEBCresume(
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements;
ForeachVarList *varListPtr;
- int numLists, iterMax, listLen, numVars;
- int iterTmp, iterNum, listTmpDepth;
+ int numLists, listLen, numVars;
+ int listTmpDepth;
+ size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
@@ -7017,7 +6768,7 @@ TEBCresume(
*/
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
TRACE(("%u => ", opnd));
@@ -7031,7 +6782,7 @@ 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;
@@ -7057,8 +6808,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 +6836,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
@@ -7103,7 +6854,7 @@ TEBCresume(
* 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;
@@ -7112,7 +6863,7 @@ TEBCresume(
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
- TclListObjGetElements(interp, listPtr, &listLen, &elements);
+ TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -7169,7 +6920,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,7 +6937,7 @@ 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));
@@ -7203,10 +6954,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 *)UINT2PTR(CURR_DEPTH);
+ TRACE(("%u => catchTop=%" TCL_Z_MODIFIER "u, stackTop=%" TCL_Z_MODIFIER "u\n",
+ TclGetUInt4AtPtr(pc+1), (size_t)(catchTop - initCatchTop - 1),
+ CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
break;
@@ -7216,7 +6967,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 +7021,8 @@ TEBCresume(
*/
{
- int opnd2, allocateDict, done, i, allocdict;
+ int opnd2, allocateDict, done, allocdict;
+ int i;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
@@ -7286,56 +7038,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 +7072,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), 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 +7178,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 +7385,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 +7400,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 +7422,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 +7459,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 +7476,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 +7519,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 +7536,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 +7595,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 +7613,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 +7644,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 +7673,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);
}
@@ -7978,7 +7770,7 @@ TEBCresume(
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;
@@ -8016,6 +7808,13 @@ TEBCresume(
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", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
@@ -8067,8 +7866,8 @@ TEBCresume(
while (auxObjList) {
if ((catchTop != initCatchTop)
- && (*catchTop > (ptrdiff_t)
- auxObjList->internalRep.twoPtrValue.ptr2)) {
+ && (PTR2UINT(*catchTop) >
+ PTR2UINT(auxObjList->internalRep.twoPtrValue.ptr2))) {
break;
}
POP_TAUX_OBJ();
@@ -8143,16 +7942,16 @@ TEBCresume(
*/
processCatch:
- while (CURR_DEPTH > *catchTop) {
+ while (CURR_DEPTH > PTR2UINT(*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 %d, catchTop=%" TCL_Z_MODIFIER "u, "
+ "unwound to %" TCL_Z_MODIFIER "u, new pc %" TCL_Z_MODIFIER "u\n",
+ rangePtr->codeOffset, (size_t)(catchTop - initCatchTop - 1),
+ PTR2UINT(*catchTop), (size_t)rangePtr->catchOffset);
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
@@ -8188,19 +7987,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_Z_MODIFIER "u: "
+ "stack top %" TCL_Z_MODIFIER "u < entry stack top %d\n",
+ (size_t)(pc - codePtr->codeStart),
+ CURR_DEPTH, 0);
Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
}
CLANG_ASSERT(bcFramePtr);
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
@@ -8258,18 +8055,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 +8081,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 +8106,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 +8223,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 +8247,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;
long shift;
+ mp_err err;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
@@ -8511,13 +8263,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 +8277,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 +8297,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 +8312,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 +8335,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, 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 +8367,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type2) {
- case TCL_NUMBER_LONG:
- invalid = (*((const long *)ptr2) < 0L);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
+ case TCL_NUMBER_INT:
+ invalid = (*((const Tcl_WideInt *)ptr2) < 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 +8389,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 +8402,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 +8415,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 +8435,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 +8446,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 +8461,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 +8501,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 +8531,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 +8564,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 +8625,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 long int 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). */
-
- 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.
- */
+ /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */
+ assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT);
- 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 +8706,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 +8720,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 +8733,6 @@ ExecuteExtendedBinaryMathOp(
WIDE_RESULT(wResult);
}
}
-#endif
overflowExpon:
@@ -9081,8 +8744,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 +8803,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 +8831,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 +8851,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 +8863,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 +8897,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 +8950,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,34 +9030,25 @@ 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
@@ -9396,7 +9056,7 @@ TclCompareTwoNumbers(
* 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 +9073,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 +9092,6 @@ TclCompareTwoNumbers(
return compare;
}
break;
-#endif
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
@@ -9480,44 +9100,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 {
@@ -9540,21 +9143,18 @@ 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;
@@ -9609,10 +9209,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 +9226,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 +9270,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 +9344,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";
@@ -9758,7 +9357,7 @@ IllegalExprOperandType(
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
+ const char *bytes = TclGetStringFromObj(opndPtr, &numBytes);
if (numBytes == 0) {
description = "empty string";
@@ -9777,7 +9376,8 @@ IllegalExprOperandType(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't use %s as operand of \"%s\"", description, op));
+ "can't use %s \"%s\" as operand of \"%s\"", description,
+ TclGetString(opndPtr), op));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
}
@@ -9854,7 +9454,8 @@ TclGetSrcInfoForPc(
ExtCmdLoc *eclPtr;
ECL *locPtr = NULL;
- int srcOffset, i;
+ int srcOffset;
+ int i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
@@ -9864,7 +9465,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) {
@@ -10089,7 +9690,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,11 +9753,11 @@ 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)) {
+ } 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));
@@ -10171,7 +9772,7 @@ TclExprFloatError(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
- Tcl_GetString(objPtr), NULL);
+ TclGetString(objPtr), NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
@@ -10229,7 +9830,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 +9843,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 +9873,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 +9888,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 +9905,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 +9915,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 +9936,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 +9957,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 +9985,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 +10004,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",
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 +10042,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 +10092,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;
@@ -10523,7 +10125,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;
@@ -10546,7 +10148,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;
@@ -10569,7 +10171,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 +10191,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 +10203,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 +10211,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..1ad7e1a 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 **)
@@ -1085,12 +1085,9 @@ TclFileAttrsCmd(
}
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;
@@ -1113,12 +1110,9 @@ TclFileAttrsCmd(
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])));
@@ -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 b3294fd..ac0dfa3 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);
@@ -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
@@ -1311,7 +1318,7 @@ Tcl_GlobObjCmd(
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++;
@@ -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
@@ -1433,7 +1440,7 @@ Tcl_GlobObjCmd(
* platform.
*/
- TclListObjLength(interp, typePtr, &length);
+ TclListObjLengthM(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
@@ -1448,7 +1455,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 +1510,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))) {
@@ -1610,7 +1617,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.
@@ -1692,7 +1699,7 @@ Tcl_GlobObjCmd(
*----------------------------------------------------------------------
*/
-int
+static int
TclGlob(
Tcl_Interp *interp, /* Interpreter for returning error message or
* appending list of matching file names. */
@@ -1760,7 +1767,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 +1874,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 +1985,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 +2000,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) {
@@ -2326,13 +2329,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);
@@ -2345,14 +2348,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);
@@ -2390,7 +2393,7 @@ DoGlob(
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
- (void) Tcl_GetStringFromObj(pathPtr, &length);
+ (void) TclGetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
@@ -2424,7 +2427,7 @@ DoGlob(
*/
if (pathPtr == NULL) {
- joinedPtr = TclDStringToObj(&append);
+ joinedPtr = Tcl_DStringToObj(&append);
} else if (flags) {
joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
@@ -2436,7 +2439,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);
@@ -2473,7 +2476,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) {
@@ -2538,21 +2541,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
@@ -2583,61 +2586,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 412f03f..08c0193 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;
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 7e83e89..57c1554 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,8 +102,8 @@ 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. */
- char buffer[1]; /* Copy buffer, this must be the last
+ 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,
@@ -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);
}
/*
@@ -376,13 +395,13 @@ ChanClose(
* Results:
* The return value of the driver inputProc,
* - number of bytes stored at dst, ot
- * - -1 on error, with a Posix error code available to the caller by
+ * - TCL_INDEX_NONE on error, with a Posix error code available to the caller by
* 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?
*
@@ -414,7 +433,7 @@ ChanRead(
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (WillRead(chanPtr) < 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
@@ -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
@@ -557,7 +581,6 @@ TclInitIOSubsystem(void)
*-------------------------------------------------------------------------
*/
- /* ARGSUSED */
void
TclFinalizeIOSubsystem(void)
{
@@ -826,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;
@@ -864,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;
@@ -963,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. */
@@ -1216,7 +1239,7 @@ Tcl_UnregisterChannel(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
- " of channel", -1));
+ " of channel", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -1457,7 +1480,7 @@ Tcl_GetChannel(
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
chanPtr = chanPtr->state->bottomChanPtr;
if (modePtr != NULL) {
- *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE);
+ *modePtr = GotFlag(chanPtr->state, TCL_READABLE|TCL_WRITABLE);
}
return (Tcl_Channel) chanPtr;
@@ -1493,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 */
@@ -1526,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;
@@ -1553,7 +1574,7 @@ TclGetChannelFromObj(
*channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
- *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE);
+ *modePtr = GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE);
}
return TCL_OK;
@@ -1579,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. */
{
@@ -1602,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);
}
@@ -1614,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
@@ -1651,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.
@@ -1669,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
@@ -1801,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. */
@@ -1847,7 +1884,7 @@ Tcl_StackChannel(
* --+---+---+---+----+
*/
- if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
+ if ((mask & GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE)) == 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"reading and writing both disallowed for channel \"%s\"",
@@ -2137,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);
@@ -2257,7 +2297,7 @@ Tcl_GetTopChannel(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetChannelInstanceData(
Tcl_Channel chan) /* Channel for which to return client data. */
{
@@ -2345,7 +2385,7 @@ Tcl_GetChannelMode(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of actual channel. */
- return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE));
+ return GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE);
}
/*
@@ -2396,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;
@@ -2418,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 --
@@ -2443,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);
@@ -2462,7 +2550,7 @@ static void
PreserveChannelBuffer(
ChannelBuffer *bufPtr)
{
- if (bufPtr->refCount == 0) {
+ if (!bufPtr->refCount) {
Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr);
}
bufPtr->refCount++;
@@ -2529,7 +2617,7 @@ RecycleBuffer(
* This is to honor dynamic changes of the buffe rsize made by the user.
*/
- if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) {
+ if ((bufPtr->bufLength) != statePtr->bufSize + BUFFER_PADDING) {
ReleaseChannelBuffer(bufPtr);
return;
}
@@ -2639,7 +2727,7 @@ CheckForDeadChannel(
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unable to access channel: invalid channel", -1));
+ "unable to access channel: invalid channel", TCL_INDEX_NONE));
}
return 1;
}
@@ -2682,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
@@ -2836,7 +2925,7 @@ FlushChannel(
if (interp != NULL && !TclChanCaughtErrorBypass(interp,
(Tcl_Channel) chanPtr)) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj(Tcl_PosixError(interp), -1));
+ Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
}
/*
@@ -2850,8 +2939,8 @@ FlushChannel(
* queued.
*/
- DiscardOutputQueued(statePtr);
ReleaseChannelBuffer(bufPtr);
+ DiscardOutputQueued(statePtr);
break;
} else {
/*
@@ -2862,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". */
/*
@@ -3093,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);
/*
@@ -3360,12 +3455,12 @@ Tcl_SpliceChannel(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
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. */
@@ -3405,7 +3500,7 @@ Tcl_Close(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
- " of channel", -1));
+ " of channel", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -3450,6 +3545,11 @@ Tcl_Close(
Tcl_ClearChannelHandlers(chan);
/*
+ * Cancel any outstanding timer.
+ */
+ DeleteTimerHandler(statePtr);
+
+ /*
* Invoke the registered close callbacks and delete their records.
*/
@@ -3467,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);
@@ -3474,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
@@ -3506,7 +3613,7 @@ Tcl_Close(
Tcl_SetErrno(stickyError);
if (interp != NULL) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj(Tcl_PosixError(interp), -1));
+ Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -3521,10 +3628,10 @@ 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));
+ Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE));
}
if (result != 0) {
return TCL_ERROR;
@@ -3537,24 +3644,21 @@ 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.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_CloseEx(
Tcl_Interp *interp, /* Interpreter for errors. */
@@ -3599,7 +3703,7 @@ Tcl_CloseEx(
if (chanPtr != statePtr->topChanPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "half-close not applicable to stack of transformations", -1));
+ "half-close not applicable to stack of transformations", TCL_INDEX_NONE));
return TCL_ERROR;
}
@@ -3609,7 +3713,7 @@ Tcl_CloseEx(
* opened for that direction).
*/
- if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) {
+ if (!(GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & flags)) {
const char *msg;
if (flags & TCL_CLOSE_READ) {
@@ -3628,11 +3732,11 @@ Tcl_CloseEx(
* That won't do.
*/
- if (statePtr->flags & CHANNEL_INCLOSE) {
+ if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
- " of channel", -1));
+ " of channel", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -3918,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
@@ -3991,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
@@ -4001,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(). */
{
/*
@@ -4019,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;
}
@@ -4045,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
@@ -4055,20 +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, written;
+ int errorCode;
+ Tcl_Size written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (srcLen < 0) {
@@ -4101,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
@@ -4111,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;
@@ -4170,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
@@ -4180,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. */
@@ -4192,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);
@@ -4215,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,11 +4337,13 @@ WillRead(
DiscardInputQueued(chanPtr->state, 0);
Tcl_SetErrno(EINVAL);
- return -1;
+ return TCL_INDEX_NONE;
}
- 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
@@ -4251,7 +4355,7 @@ WillRead(
*/
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
}
return 0;
@@ -4268,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:
@@ -4332,7 +4436,6 @@ Write(
bufPtr->nextAdded += saved;
saved = 0;
}
- PreserveChannelBuffer(bufPtr);
dst = InsertPoint(bufPtr);
dstLen = SpaceLeft(bufPtr);
@@ -4347,7 +4450,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;
}
@@ -4418,8 +4538,7 @@ Write(
if (IsBufferFull(bufPtr)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- ReleaseChannelBuffer(bufPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
flushed += statePtr->bufSize;
@@ -4438,18 +4557,19 @@ Write(
needNlFlush = 0;
}
}
- ReleaseChannelBuffer(bufPtr);
}
if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
}
+ UpdateInterest(chanPtr);
+
if (encodingError) {
- Tcl_SetErrno(EINVAL);
- return -1;
+ Tcl_SetErrno(EILSEQ);
+ return TCL_INDEX_NONE;
}
return total;
}
@@ -4462,8 +4582,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:
@@ -4473,7 +4593,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
@@ -4482,7 +4602,7 @@ Tcl_Gets(
* for managing the storage. */
{
Tcl_Obj *objPtr;
- int charsStored;
+ Tcl_Size charsStored;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
@@ -4503,8 +4623,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:
@@ -4516,7 +4636,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 +4647,20 @@ Tcl_GetsObj(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
+ int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
+ Tcl_Size oldLength;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return TCL_INDEX_NONE;
+ }
+
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -4548,7 +4675,7 @@ Tcl_GetsObj(
/* TODO: Do we need this? */
UpdateInterest(chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -4675,7 +4802,7 @@ Tcl_GetsObj(
*/
if (eol >= dstEnd) {
- int offset;
+ Tcl_Size offset;
if (eol != eof) {
offset = eol - objPtr->bytes;
@@ -4788,6 +4915,19 @@ Tcl_GetsObj(
goto done;
}
goto gotEOL;
+ } else if (gs.bytesWrote == 0
+ && GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
+ && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+ /* Set eol to the position that caused the encoding error, and then
+ * coninue 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
+ * succesfully decoded, allowing further processing at exactly that
+ * point, if desired.
+ */
+ eol = dstEnd;
+ goto gotEOL;
}
dst = dstEnd;
}
@@ -4887,6 +5027,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 +5044,11 @@ Tcl_GetsObj(
}
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) &&
+ (copiedTotal == 0 || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
+ Tcl_SetErrno(EILSEQ);
+ copiedTotal = -1;
+ }
return copiedTotal;
}
@@ -4920,8 +5066,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 +5089,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,12 +5215,12 @@ 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);
CommonGetsCleanup(chanPtr);
- copiedTotal = -1;
+ copiedTotal = TCL_INDEX_NONE;
ResetFlag(statePtr, CHANNEL_BLOCKED);
goto done;
}
@@ -5162,7 +5309,7 @@ TclGetsObjBinary(
*/
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
- copiedTotal = -1;
+ copiedTotal = TCL_INDEX_NONE;
/*
* Update the notifier state so we don't block while there is still data
@@ -5196,10 +5343,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);
@@ -5208,7 +5354,7 @@ FreeBinaryEncoding(
}
static Tcl_Encoding
-GetBinaryEncoding()
+GetBinaryEncoding(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -5352,11 +5498,17 @@ FilterInputBytes(
*gsPtr->dstPtr = dst;
}
gsPtr->state = statePtr->inputEncodingState;
+
result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE,
&statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead,
&gsPtr->bytesWrote, &gsPtr->charsWrote);
+ if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) {
+ SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
+ result = TCL_OK;
+ }
+
/*
* Make sure that if we go through 'gets', that we reset the
* TCL_ENCODING_START flag still. [Bug #523988]
@@ -5576,7 +5728,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:
@@ -5585,11 +5737,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;
@@ -5602,7 +5754,7 @@ Tcl_Read(
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
return DoRead(chanPtr, dst, bytesToRead, 0);
@@ -5621,7 +5773,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:
@@ -5630,11 +5782,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;
@@ -5643,7 +5795,7 @@ Tcl_ReadRaw(
assert(bytesToRead > 0);
if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -5697,13 +5849,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
@@ -5715,8 +5861,14 @@ Tcl_ReadRaw(
*/
if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) {
- copied = -1;
+ copied = TCL_INDEX_NONE;
}
+ } 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.
@@ -5739,7 +5891,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:
@@ -5748,12 +5900,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,
@@ -5777,10 +5929,10 @@ Tcl_ReadChars(
*/
UpdateInterest(chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
- return DoReadChars(chanPtr, objPtr, toRead, appendFlag);
+ return DoReadChars(chanPtr, objPtr, toRead, 0, appendFlag);
}
/*
*---------------------------------------------------------------------------
@@ -5795,7 +5947,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:
@@ -5804,13 +5956,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
@@ -5819,34 +5972,19 @@ DoReadChars(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- int copied, copiedNow, result;
+ Tcl_Size copied;
+ int result, copiedNow;
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)) {
+ /* TODO: We don't need this call? */
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return -1;
}
-
/*
* Early out when next read will see eofchar.
*
@@ -5885,6 +6023,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 == TclGetBytesFromObj(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.
*/
@@ -5895,7 +6059,7 @@ DoReadChars(
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
for (copied = 0; (unsigned) toRead > 0; ) {
- copiedNow = -1;
+ copiedNow = TCL_INDEX_NONE;
if (statePtr->inQueueHead != NULL) {
if (binaryMode) {
copiedNow = ReadBytes(statePtr, objPtr, toRead);
@@ -5917,14 +6081,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);
@@ -5935,7 +6112,7 @@ DoReadChars(
}
if (result != 0) {
if (!GotFlag(statePtr, CHANNEL_BLOCKED)) {
- copied = -1;
+ copied = TCL_INDEX_NONE;
}
break;
}
@@ -5945,6 +6122,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
@@ -5956,7 +6134,7 @@ DoReadChars(
}
/*
- * Regenerate the top channel, in case it was changed due to
+ * Regenerate chanPtr in case it was changed due to
* self-modifying reflected transforms.
*/
@@ -5973,10 +6151,22 @@ 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.
+ */
+ Tcl_SetErrno(EILSEQ);
+ copied = -1;
+ }
TclChannelRelease((Tcl_Channel)chanPtr);
return copied;
}
@@ -5996,7 +6186,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.
@@ -6012,7 +6202,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
@@ -6065,7 +6255,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
@@ -6089,7 +6279,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
@@ -6165,6 +6356,11 @@ ReadChars(
flags, &statePtr->inputEncodingState,
dst, dstLimit, &srcRead, &dstDecoded, &numChars);
+ if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) {
+ 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.
@@ -6192,12 +6388,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.
@@ -6212,7 +6408,7 @@ ReadChars(
*/
Tcl_SetObjLength(objPtr, numBytes);
- return -1;
+ return TCL_INDEX_NONE;
}
{
@@ -6300,7 +6496,7 @@ ReadChars(
return 1;
}
- } else if (statePtr->flags & CHANNEL_EOF) {
+ } else if (GotFlag(statePtr, CHANNEL_EOF)) {
/*
* The bare \r is the only char and we will never read a
* subsequent char to make the determination.
@@ -6340,7 +6536,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;
@@ -6387,7 +6583,7 @@ ReadChars(
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
}
Tcl_SetObjLength(objPtr, numBytes);
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -6403,7 +6599,7 @@ ReadChars(
* precautions.
*/
- if (nextPtr->nextRemoved - srcLen < 0) {
+ if (nextPtr->nextRemoved < srcLen) {
Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
}
@@ -6566,7 +6762,7 @@ TranslateInputEOL(
char *dst = dstStart;
int lesser;
- if ((statePtr->flags & INPUT_SAW_CR) && srcLen) {
+ if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) {
if (*src == '\n') { src++; srcLen--; }
ResetFlag(statePtr, INPUT_SAW_CR);
}
@@ -6601,11 +6797,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);
}
}
@@ -6618,7 +6817,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.
@@ -6626,11 +6825,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. */
{
@@ -6654,7 +6853,7 @@ Tcl_Ungets(
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- len = -1;
+ len = TCL_INDEX_NONE;
goto done;
}
statePtr->flags = flags;
@@ -6839,24 +7038,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
@@ -6900,7 +7096,7 @@ GetInput(
*/
if ((bufPtr != NULL)
- && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) {
+ && (bufPtr->bufLength != statePtr->bufSize + BUFFER_PADDING)) {
ReleaseChannelBuffer(bufPtr);
bufPtr = NULL;
}
@@ -6925,15 +7121,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;
}
@@ -6955,10 +7153,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;
@@ -6968,7 +7166,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. */
@@ -6999,7 +7197,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;
}
@@ -7124,7 +7326,7 @@ Tcl_Seek(
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
Tcl_Tell(
Tcl_Channel chan) /* The channel to return pos for. */
{
@@ -7135,7 +7337,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;
@@ -7163,7 +7365,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;
}
@@ -7197,47 +7403,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.
@@ -7256,7 +7421,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 =
@@ -7370,7 +7535,7 @@ CheckChannelErrors(
* Fail if the channel is not opened for desired operation.
*/
- if ((statePtr->flags & direction) == 0) {
+ if (GotFlag(statePtr, direction) == 0) {
Tcl_SetErrno(EACCES);
return -1;
}
@@ -7418,6 +7583,9 @@ 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;
}
@@ -7588,7 +7756,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. */
@@ -7642,7 +7810,7 @@ Tcl_SetChannelBufferSize(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_GetChannelBufferSize(
Tcl_Channel chan) /* The channel for which to find the buffer
* size. */
@@ -7692,17 +7860,17 @@ 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;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, genericopt, -1);
+ Tcl_DStringAppend(&ds, genericopt, TCL_INDEX_NONE);
if (optionList && (*optionList)) {
TclDStringAppendLiteral(&ds, " ");
- Tcl_DStringAppend(&ds, optionList, -1);
+ Tcl_DStringAppend(&ds, optionList, TCL_INDEX_NONE);
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
@@ -7892,6 +8060,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");
@@ -7987,8 +8172,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.
@@ -7998,7 +8183,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to set channel options: background copy in"
- " progress", -1));
+ " progress", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -8049,7 +8234,7 @@ Tcl_SetChannelOption(
} else if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
- " full, line, or none", -1));
+ " full, line, or none", TCL_INDEX_NONE));
return TCL_ERROR;
}
return TCL_OK;
@@ -8063,6 +8248,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;
@@ -8087,29 +8273,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;
@@ -8124,7 +8316,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;
@@ -8145,6 +8337,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;
@@ -8162,7 +8363,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
- " element list", -1));
+ " element list", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8192,7 +8393,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
- "auto, binary, cr, lf, crlf, or platform", -1));
+ "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8242,7 +8443,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
- "auto, binary, cr, lf, crlf, or platform", -1));
+ "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8572,6 +8773,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);
}
@@ -8594,39 +8807,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;
+}
/*
*----------------------------------------------------------------------
@@ -8659,7 +8912,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;
@@ -8690,7 +8943,7 @@ Tcl_CreateChannelHandler(
/*
* The remainder of the initialization below is done regardless of whether
- * or not this is a new record or a modification of an old one.
+ * this is a new record or a modification of an old one.
*/
chPtr->mask = mask;
@@ -8731,7 +8984,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);
@@ -8937,21 +9190,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]).
*/
@@ -9004,10 +9256,9 @@ TclChannelEventScriptInvoker(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
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. */
@@ -9021,7 +9272,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?");
@@ -9040,7 +9290,7 @@ Tcl_FileEventObjCmd(
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
- if ((statePtr->flags & mask) == 0) {
+ if (GotFlag(statePtr, mask) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s",
(mask == TCL_READABLE) ? "readable" : "writable"));
return TCL_ERROR;
@@ -9102,7 +9352,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.
@@ -9131,6 +9381,7 @@ ZeroTransferTimerProc(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
@@ -9142,13 +9393,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;
@@ -9205,8 +9457,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
@@ -9217,7 +9469,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
@@ -9225,7 +9479,7 @@ TclCopyChannel(
* completed.
*/
- csPtr = (CopyState *)ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize);
+ csPtr = (CopyState *)ckalloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
@@ -9336,7 +9590,7 @@ MBError(
static void
MBEvent(
- ClientData clientData,
+ void *clientData,
int mask)
{
CopyState *csPtr = (CopyState *) clientData;
@@ -9415,13 +9669,13 @@ MBWrite(
if (bufPtr) {
/* Split the overflowing buffer in two */
int extra = (int) (inBytes - csPtr->toRead);
- /* Note that going with int for extra assumes that inBytes is not too
- * much over toRead to require a wide itself. If that gets violated
- * 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.
- */
+ /* Note that going with int for extra assumes that inBytes is not too
+ * much over toRead to require a wide itself. If that gets violated
+ * then the calculations involving extra must be made wide too.
+ *
+ * Noted with Win32/MSVC debug build treating the warning (possible of
+ * data in long long to int conversion) as error.
+ */
bufPtr = AllocChannelBuffer(extra);
@@ -9519,7 +9773,8 @@ CopyData(
Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
- int result = TCL_OK, size, sizeb;
+ int result = TCL_OK, size;
+ Tcl_Size sizeb;
Tcl_WideInt total;
const char *buffer;
int inBinary, outBinary, sameEncoding;
@@ -9543,7 +9798,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);
@@ -9560,12 +9817,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)) {
@@ -9593,7 +9858,8 @@ CopyData(
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
- 0 /* No append */);
+ !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)
+ ,0 /* No append */);
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
@@ -9826,7 +10092,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.
*
@@ -9835,7 +10101,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.
@@ -9843,11 +10109,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;
@@ -9867,6 +10133,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);
@@ -9934,7 +10205,7 @@ DoRead(
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
assert(IsBufferFull(bufPtr));
@@ -9964,10 +10235,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;
}
@@ -9985,7 +10256,7 @@ DoRead(
* There's no more buffered data...
*/
- if (statePtr->flags & CHANNEL_EOF) {
+ if (GotFlag(statePtr, CHANNEL_EOF)) {
/*
* ...and there never will be.
*/
@@ -9993,7 +10264,7 @@ DoRead(
*p++ = '\r';
bytesToRead--;
bufPtr->nextRemoved++;
- } else if (statePtr->flags & CHANNEL_BLOCKED) {
+ } else if (GotFlag(statePtr, CHANNEL_BLOCKED)) {
/*
* ...and we cannot get more now.
*/
@@ -10052,6 +10323,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)));
@@ -10080,7 +10352,7 @@ DoRead(
static void
CopyEventProc(
- ClientData clientData,
+ void *clientData,
int mask)
{
(void) CopyData((CopyState *)clientData, mask);
@@ -10126,20 +10398,20 @@ StopCopy(
*/
nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING;
- if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) {
+ if (nonBlocking != GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->readPtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
if (csPtr->readPtr != csPtr->writePtr) {
nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING;
- if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
+ if (nonBlocking != GotFlag(outStatePtr, CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->writePtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
}
ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
- outStatePtr->flags |=
- csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED);
+ SetFlag(outStatePtr,
+ csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED));
if (csPtr->cmdPtr) {
Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr);
@@ -10342,7 +10614,7 @@ Tcl_GetChannelNamesEx(
&& (pattern[2] == 'd'))) {
if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL)
&& (Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(pattern, -1)) != TCL_OK)) {
+ Tcl_NewStringObj(pattern, TCL_INDEX_NONE)) != TCL_OK)) {
goto error;
}
goto done;
@@ -10369,7 +10641,7 @@ Tcl_GetChannelNamesEx(
if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
(Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(name, -1)) != TCL_OK)) {
+ Tcl_NewStringObj(name, TCL_INDEX_NONE)) != TCL_OK)) {
error:
TclDecrRefCount(resultPtr);
return TCL_ERROR;
@@ -10550,6 +10822,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)) {
/*
@@ -10558,6 +10831,7 @@ Tcl_ChannelVersion(
*/
return TCL_CHANNEL_VERSION_1;
}
+#endif
return chanTypePtr->version;
}
@@ -10581,13 +10855,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;
}
@@ -10607,6 +10882,7 @@ Tcl_ChannelBlockModeProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10614,6 +10890,7 @@ Tcl_ChannelCloseProc(
{
return chanTypePtr->closeProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10703,6 +10980,7 @@ Tcl_ChannelOutputProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10710,6 +10988,7 @@ Tcl_ChannelSeekProc(
{
return chanTypePtr->seekProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10828,9 +11107,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;
}
@@ -10855,9 +11136,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;
}
@@ -10882,9 +11165,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;
}
@@ -10910,9 +11195,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;
}
@@ -10939,15 +11226,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;
}
@@ -10975,15 +11264,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;
}
@@ -11011,7 +11302,8 @@ static Tcl_Obj *
FixLevelCode(
Tcl_Obj *msg)
{
- int explicitResult, numOptions, lc, lcn;
+ int explicitResult, numOptions, lcn;
+ Tcl_Size lc;
Tcl_Obj **lv, **lvn;
int res, i, j, val, lignore, cignore;
int newlevel = -1, newcode = -1;
@@ -11028,7 +11320,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");
}
@@ -11104,7 +11396,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;
@@ -11114,7 +11406,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;
@@ -11256,11 +11548,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);
}
/*
@@ -11283,10 +11575,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);
@@ -11304,8 +11597,8 @@ DumpFlags(
char *str,
int flags)
{
- char buf[20];
int i = 0;
+ char buf[24];
#define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))
@@ -11318,6 +11611,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..729db5d 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;
/*
@@ -163,7 +163,7 @@ typedef struct ChannelState {
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 +186,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 +217,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;
/*
@@ -272,9 +274,10 @@ 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_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 eb4ae78..bc4fab4 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. */
@@ -114,7 +108,6 @@ Tcl_PutsObjCmd(
int newline; /* Add a newline at end? */
int result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
- ThreadSpecificData *tsdPtr;
switch (objc) {
case 2: /* [puts $x] */
@@ -139,7 +132,7 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[2];
string = objv[3];
break;
-#if TCL_MAJOR_VERSION < 9
+#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
@@ -161,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;
@@ -228,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. */
@@ -293,10 +285,9 @@ 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. */
@@ -344,7 +335,7 @@ Tcl_GetsObjCmd(
code = TCL_ERROR;
goto done;
}
- lineLen = -1;
+ lineLen = TCL_INDEX_NONE;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
@@ -352,7 +343,7 @@ Tcl_GetsObjCmd(
code = TCL_ERROR;
goto done;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen));
} else {
Tcl_SetObjResult(interp, linePtr);
}
@@ -378,10 +369,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. */
@@ -441,7 +431,7 @@ Tcl_ReadObjCmd(
if (i < objc) {
if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -456,7 +446,7 @@ Tcl_ReadObjCmd(
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
@@ -522,10 +512,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. */
@@ -561,7 +550,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
@@ -598,10 +587,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. */
@@ -661,10 +649,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. */
@@ -770,10 +757,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. */
@@ -846,10 +832,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. */
@@ -886,10 +871,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. */
@@ -899,12 +883,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;
+ int length;
static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
- enum options {
+ enum execOptionsEnum {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
@@ -954,7 +938,7 @@ Tcl_ExecObjCmd(
*/
argc = objc - skip;
- argv = 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
@@ -993,7 +977,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
@@ -1054,10 +1038,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. */
@@ -1101,10 +1084,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. */
@@ -1162,7 +1144,8 @@ Tcl_OpenObjCmd(
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
- int mode, seekFlag, cmdObjc, binary;
+ int mode, seekFlag, binary;
+ int cmdObjc;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
@@ -1225,20 +1208,19 @@ 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 = clientData;
+ Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
- AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr);
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = NULL;
}
@@ -1280,10 +1262,10 @@ RegisterTcpServerInterpCleanup(
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
- hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
+ hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
- hTblPtr = ckalloc(sizeof(Tcl_HashTable));
+ hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
@@ -1326,7 +1308,7 @@ UnregisterTcpServerInterpCleanupProc(
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
- hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
+ hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
@@ -1356,7 +1338,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
@@ -1364,7 +1346,7 @@ AcceptCallbackProc(
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
- AcceptCallback *acceptCallbackPtr = callbackData;
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
@@ -1373,15 +1355,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);
/*
@@ -1391,8 +1380,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);
@@ -1406,7 +1396,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
@@ -1440,17 +1429,17 @@ 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 = callbackData;
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
- Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
+ Tcl_DecrRefCount(acceptCallbackPtr->script);
ckfree(acceptCallbackPtr);
}
@@ -1473,27 +1462,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 optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1,
+ 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;
@@ -1502,7 +1494,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(
@@ -1548,7 +1540,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");
@@ -1570,35 +1595,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 =
- ckalloc(sizeof(AcceptCallback));
- unsigned len = strlen(script) + 1;
- char *copyScript = 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;
}
@@ -1620,7 +1676,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;
}
@@ -1651,7 +1713,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. */
@@ -1744,10 +1806,9 @@ 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. */
@@ -1755,7 +1816,7 @@ ChanPendingObjCmd(
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};
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
@@ -1771,19 +1832,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;
}
@@ -1809,7 +1870,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. */
@@ -1844,7 +1905,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)));
@@ -1882,7 +1943,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. */
@@ -1933,7 +1994,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..51fa94d 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. */
@@ -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;
@@ -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 3eca3f8..29f47ba 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
@@ -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)
@@ -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...
@@ -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.
*/
@@ -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,9 +1228,15 @@ ReflectClose(
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
+ 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, (Tcl_FreeProc *) 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, (Tcl_FreeProc *) 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,7 +1334,7 @@ ReflectClose2(
static int
ReflectInput(
- ClientData clientData,
+ void *clientData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -1288,7 +1349,7 @@ ReflectInput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -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 */
@@ -1889,9 +1952,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 +2025,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;
}
@@ -1979,7 +2042,7 @@ ReflectGetOption(
goto error;
} else {
int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
@@ -2003,6 +2066,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. =========================================================
*/
@@ -2041,7 +2171,7 @@ EncodeEventMask(
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 +2267,7 @@ NewReflectedChannel(
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
- MethodName mn = METH_BLOCKING;
+ int mn = 0;
rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));
@@ -2146,7 +2276,9 @@ 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;
@@ -2156,7 +2288,7 @@ NewReflectedChannel(
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));
}
@@ -2346,7 +2478,7 @@ InvokeTclMethod(
if (result != TCL_ERROR) {
int cmdLen;
- const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+ const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
@@ -2425,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;
@@ -2462,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;
}
@@ -2512,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;
@@ -2521,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;
@@ -2551,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.
*/
@@ -2634,10 +2765,12 @@ DeleteReflectedChannelMap(
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
+#else
+ (void)interp;
#endif
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2689,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. */
@@ -2697,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.
@@ -2867,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
@@ -2916,7 +3048,7 @@ ForwardOpToHandlerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /* mask */)
{
/*
* HANDLER thread.
@@ -2945,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.
@@ -3079,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);
@@ -3198,7 +3332,7 @@ ForwardProc(
int listc;
Tcl_Obj **listv;
- if (TclListObjGetElements(interp, resObj, &listc,
+ if (TclListObjGetElementsM(interp, resObj, &listc,
&listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
@@ -3216,7 +3350,7 @@ ForwardProc(
ForwardSetDynamicError(paramPtr, buf);
} else {
int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
@@ -3227,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.
@@ -3263,7 +3410,7 @@ ForwardProc(
static void
SrcExitProc(
- ClientData clientData)
+ void *clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
@@ -3315,7 +3462,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));
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 730820e..8ab1ffb9 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,
(Tcl_FreeProc *) 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,
(Tcl_FreeProc *) 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, (Tcl_FreeProc *) 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.
@@ -2055,7 +2045,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);
@@ -2157,17 +2147,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 */
/*
@@ -2194,7 +2186,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.
*/
@@ -2266,7 +2258,7 @@ DeleteReflectedTransformMap(
#endif /* TCL_THREADS */
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2318,14 +2310,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.
@@ -2463,8 +2454,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
@@ -2513,7 +2504,7 @@ ForwardOpToOwnerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /*mask*/)
{
/*
* Notes regarding access to the referenced data.
@@ -2538,7 +2529,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.
@@ -2582,7 +2572,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);
/*
@@ -2592,7 +2582,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);
@@ -2769,7 +2759,7 @@ ForwardProc(
static void
SrcExitProc(
- ClientData clientData)
+ void *clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
@@ -2821,7 +2811,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));
@@ -2909,7 +2899,7 @@ TimerSetup(
static void
TimerRun(
- ClientData clientData)
+ void *clientData)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -2969,7 +2959,7 @@ ResultClear(
return;
}
- ckfree((char *) rPtr->buf);
+ ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
@@ -3102,7 +3092,7 @@ TransformRead(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3158,7 +3148,7 @@ TransformWrite(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3224,7 +3214,7 @@ TransformDrain(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3274,7 +3264,7 @@ TransformFlush(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3329,7 +3319,7 @@ TransformClear(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3361,7 +3351,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 ca11172..f665e0f 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) {
@@ -782,7 +765,9 @@ TclFinalizeFilesystem(void)
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 +780,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 +812,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 +819,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 +852,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 +867,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 +884,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 +911,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 +929,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 +955,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 +993,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 +1008,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 +1025,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 +1062,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 +1082,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 +1113,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 +1148,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 +1166,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 +1187,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 +1251,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 +1265,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 +1290,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 +1315,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 +1397,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 +1412,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 +1443,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 +1490,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 +1504,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 +1522,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 +1552,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 +1649,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 +1660,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 +1714,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 +1751,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 +1772,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 +1796,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 +1816,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 +1847,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 +1888,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 +1913,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 +1929,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 +1948,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 +1971,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 +1988,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 +2000,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 +2018,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,24 +2030,21 @@ 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;
@@ -2104,11 +2060,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 +2075,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 +2093,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 +2110,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 +2133,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 +2148,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 +2165,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 +2203,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 +2213,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Do the actual open() call.
+ * Open the file.
*/
retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
@@ -2267,7 +2223,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 +2260,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,9 +2276,8 @@ 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);
@@ -2337,11 +2294,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 +2310,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 +2321,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 +2344,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 +2355,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 +2373,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 +2384,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 +2420,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 +2436,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 +2475,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 +2498,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 +2518,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 +2536,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 +2554,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 +2572,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).
+ * Replaces the library version of getcwd().
*
- * 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.
+ * 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).
*
- * 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.
- *
- * 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 +2609,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 +2621,7 @@ Tcl_FSGetCwd(
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
+
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
@@ -2683,7 +2637,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 +2645,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 +2674,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 +2723,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 +2759,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 +2785,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 +2834,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 +2871,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 +2922,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 +2986,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 +3004,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 +3041,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 +3085,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 +3152,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 +3198,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 +3216,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 +3234,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 +3249,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 +3265,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 +3277,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 +3296,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 +3303,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 +3322,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 +3333,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 +3361,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 +3405,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 +3418,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 +3428,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 +3446,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 +3469,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 +3552,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 +3578,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 +3607,45 @@ Tcl_FSUnloadFile(
*
* TclFSUnloadTempFile --
*
- * This function is called when we loaded a library of code via an
- * intermediate temporary file. This function ensures the library is
- * correctly unloaded and the temporary file is correctly deleted.
+ * Unloads an object loaded via temporary file from a virtual filesystem
+ * to a native filesystem.
*
* Results:
* None.
*
* Side effects:
- * The effects of the 'unload' function called, and of course the
- * temporary file will be deleted.
+ * Frees resources for the loaded object and deletes the temporary file.
*
*----------------------------------------------------------------------
*/
void
TclFSUnloadTempFile(
- Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
- * Tcl_FSLoadFile(). The loadHandle is a token
- * that represents the loaded file. */
+ Tcl_LoadHandle loadHandle) /* A handle for the object, as provided by a
+ * previous call to Tcl_FSLoadFile(). */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;
- /*
- * 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;
}
- /*
- * 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.
- */
-
if (tvdlPtr->unloadProcPtr != NULL) {
+ /*
+ * 'unloadProcPtr' must be called 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.
+ */
+
tvdlPtr->unloadProcPtr(tvdlPtr->loadHandle);
}
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
+ * Call the function for the native fileystem, which works even at this
* late stage.
*/
@@ -3753,33 +3653,32 @@ TclFSUnloadTempFile(
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 that was created. If encodings have
+ * already been freed because the interpreter is exiting 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.
+ * 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.
*
- * 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).
- *
- * 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 case filesystem to be freed
+ * if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
@@ -3793,38 +3692,41 @@ TclFSUnloadTempFile(
*
* 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);
@@ -3834,11 +3736,10 @@ Tcl_FSLink(
}
/*
- * 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
@@ -3854,16 +3755,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.
@@ -3880,14 +3774,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) {
@@ -3896,6 +3789,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);
}
}
@@ -3911,22 +3810,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;
@@ -3934,10 +3832,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();
@@ -3963,34 +3859,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,
@@ -4002,9 +3896,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);
@@ -4017,9 +3909,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);
@@ -4029,7 +3921,7 @@ Tcl_FSSplitPath(
p += driveNameLength;
/*
- * Add the remaining path elements to the list.
+ * Add the remaining pathname elements to the list.
*/
for (;;) {
@@ -4056,12 +3948,8 @@ Tcl_FSSplitPath(
}
}
- /*
- * Compute the number of elements in the result.
- */
-
if (lenPtr != NULL) {
- TclListObjLength(NULL, result, lenPtr);
+ TclListObjLengthM(NULL, result, lenPtr);
}
return result;
}
@@ -4070,38 +3958,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,
@@ -4122,14 +4006,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.
*
@@ -4141,49 +4025,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)
@@ -4192,16 +4072,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;
@@ -4213,7 +4092,7 @@ TclFSNonnativePathType(
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
- strVol = Tcl_GetStringFromObj(vol,&len);
+ strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
@@ -4235,7 +4114,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;
@@ -4253,12 +4132,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.
@@ -4268,10 +4148,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;
@@ -4294,27 +4173,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;
@@ -4336,15 +4215,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.
*
*---------------------------------------------------------------------------
*/
@@ -4352,8 +4230,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;
@@ -4364,7 +4242,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;
}
@@ -4372,7 +4250,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);
@@ -4380,8 +4258,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) {
@@ -4389,7 +4267,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);
@@ -4414,11 +4292,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.
@@ -4444,14 +4322,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.
*
*---------------------------------------------------------------------------
*/
@@ -4474,27 +4353,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;
@@ -4516,28 +4397,31 @@ 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);
@@ -4546,27 +4430,21 @@ Tcl_FSRemoveDirectory(
return -1;
}
- /*
- * When working recursively, we check whether the cwd lies inside this
- * directory and move it if it does.
- */
-
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,
@@ -4587,16 +4465,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.
*
*---------------------------------------------------------------------------
*/
@@ -4613,41 +4489,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;
@@ -4656,10 +4529,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();
@@ -4676,26 +4549,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.
*
*---------------------------------------------------------------------------
*/
@@ -4712,7 +4566,7 @@ Tcl_FSGetNativePath(
*
* NativeFreeInternalRep --
*
- * Free a native internal representation, which will be non-NULL.
+ * Free a native internal representation.
*
* Results:
* None.
@@ -4734,16 +4588,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.
*
*---------------------------------------------------------------------------
*/
@@ -4779,16 +4634,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
*
*---------------------------------------------------------------------------
*/
@@ -4809,8 +4661,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, "/");
@@ -4822,11 +4674,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.
@@ -4836,9 +4688,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..652853c 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);
@@ -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, &indexType);
+
+ 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, &indexType);
+ 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, &indexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
+ } else {
+ Tcl_ObjInternalRep ir;
+
+ indexRep = (IndexRep*)ckalloc(sizeof(IndexRep));
+ ir.twoPtrValue.ptr1 = indexRep;
+ Tcl_StoreInternalRep(objPtr, &indexType, &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:
@@ -381,7 +407,7 @@ Tcl_GetIndexFromObjStruct(
*entryPtr, 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);
} else if (**entryPtr) {
@@ -390,6 +416,9 @@ Tcl_GetIndexFromObjStruct(
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
+ if ((flags & TCL_NULL_OK)) {
+ Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL);
+ }
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
@@ -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, &indexType)->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, &indexType)->twoPtrValue.ptr1,
+ sizeof(IndexRep));
+
+ ir.twoPtrValue.ptr1 = dupIndexRep;
+ Tcl_StoreInternalRep(dupPtr, &indexType, &ir);
}
/*
@@ -482,7 +507,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ ckfree(TclFetchInternalRep(objPtr, &indexType)->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,7 +598,7 @@ PrefixMatchObjCmd(
case PRFMATCH_MESSAGE:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "missing value for -message", -1));
+ "missing value for -message", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
@@ -583,12 +608,12 @@ PrefixMatchObjCmd(
case PRFMATCH_ERROR:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "missing value for -error", -1));
+ "missing value for -error", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
- result = TclListObjLength(interp, objv[i], &errorLength);
+ result = TclListObjLengthM(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
@@ -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], &indexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
@@ -952,7 +979,7 @@ Tcl_WrongNumArgs(
* moderately complex condition here).
*/
- if (i<toPrint-1 || objc!=0 || message!=NULL) {
+ if (i + 1 < toPrint || objc!=0 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
@@ -966,13 +993,14 @@ 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], &indexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
@@ -1003,7 +1031,7 @@ Tcl_WrongNumArgs(
* (either another element from objv, or the message string).
*/
- if (i<objc-1 || message!=NULL) {
+ if (i + 1 < objc || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
@@ -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, &indexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index c75c2e1..1ae651d 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -24,23 +24,9 @@ scspec EXTERN
# Use at your own risk. Note that the position of functions should not
# be changed between versions to avoid gratuitous incompatibilities.
-# Replaced by Tcl_FSAccess in 8.4:
-#declare 0 {
-# int TclAccess(const char *path, int mode)
-#}
-#declare 1 {
-# int TclAccessDeleteProc(TclAccessProc_ *proc)
-#}
-#declare 2 {
-# int TclAccessInsertProc(TclAccessProc_ *proc)
-#}
declare 3 {
void TclAllocateFreeObjects(void)
}
-# Replaced by TclpChdir in 8.1:
-# declare 4 {
-# int TclChdir(Tcl_Interp *interp, char *dirName)
-# }
declare 5 {
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
@@ -51,7 +37,7 @@ declare 6 {
declare 7 {
int TclCopyAndCollapse(int 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)
}
@@ -74,37 +60,12 @@ declare 11 {
declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
-# Removed in 8.5:
-#declare 13 {
-# int TclDoGlob(Tcl_Interp *interp, char *separators,
-# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
-#}
declare 14 {
- int TclDumpMemoryInfo(ClientData clientData, int flags)
+ int TclDumpMemoryInfo(void *clientData, int flags)
}
-# Removed in 8.1:
-# declare 15 {
-# void TclExpandParseValue(ParseValue *pvPtr, int needed)
-# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-# Removed in 8.4:
-#declare 17 {
-# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
-#}
-#declare 18 {
-# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 19 {
-# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 20 {
-# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 21 {
-# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
@@ -115,32 +76,14 @@ declare 23 {
}
# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10
declare 24 {
- int TclFormatInt(char *buffer, long n)
+ int TclFormatInt(char *buffer, Tcl_WideInt n)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
-# Removed in 8.1:
-# declare 26 {
-# char *TclGetCwd(Tcl_Interp *interp)
-# }
-# Removed in 8.5:
-#declare 27 {
-# int TclGetDate(char *p, unsigned long now, long zone,
-# unsigned long *timePtr)
-#}
declare 28 {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
-# Removed in 8.4b2:
-#declare 29 {
-# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp,
-# int localIndex, Tcl_Obj *elemPtr, int flags)
-#}
-# Replaced by char *TclGetEnv(const char *name, Tcl_DString *valuePtr) in 8.1:
-# declare 30 {
-# char *TclGetEnv(const char *name)
-# }
declare 31 {
const char *TclGetExtension(const char *name)
}
@@ -148,23 +91,10 @@ declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
-# Removed in 8.5:
-#declare 33 {
-# TclCmdProcType TclGetInterpProc(void)
-#}
-declare 34 {
+declare 34 {deprecated {Use Tcl_GetIntForIndex}} {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
-# Removed in 8.4b2:
-#declare 35 {
-# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
-# int flags)
-#}
-# Removed in 8.6a2
-#declare 36 {
-# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
-#}
declare 37 {
int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
}
@@ -184,13 +114,11 @@ 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 43 {
+ Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void)
}
-# Removed in 8.5a2:
-#declare 43 {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
-# int flags)
-#}
declare 44 {
int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
}
@@ -200,20 +128,6 @@ declare 45 {
declare 46 {
int TclInExit(void)
}
-# Removed in 8.4b2:
-#declare 47 {
-# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp,
-# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
-#}
-# Removed in 8.4b2:
-#declare 48 {
-# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
-# long incrAmount)
-#}
-#declare 49 {
-# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
-# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
-#}
declare 50 {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
@@ -221,42 +135,22 @@ declare 50 {
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
-# Removed in 8.5a2:
-#declare 52 {
-# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
-# int flags)
-#}
declare 53 {
- int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char **argv)
+ int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp,
+ int argc, const char **argv)
}
declare 54 {
- int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
+ int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
-# Replaced with TclpLoadFile in 8.1:
-# declare 56 {
-# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
-# char *sym2, Tcl_PackageInitProc **proc1Ptr,
-# Tcl_PackageInitProc **proc2Ptr)
-# }
-# Signature changed to take a length in 8.1:
-# declare 57 {
-# int TclLooksLikeInt(char *p)
-# }
declare 58 {
Var *TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, const char *msg, int createPart1, int createPart2,
Var **arrayPtrPtr)
}
-# Replaced by Tcl_FSMatchInDirectory in 8.4
-#declare 59 {
-# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
-# Tcl_DString *dirPtr, char *pattern, char *tail)
-#}
declare 60 {
int TclNeedSpace(const char *start, const char *end)
}
@@ -267,46 +161,18 @@ declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
- int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
+ int TclObjInterpProc(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
-# Removed in 8.5a2:
-#declare 65 {
-# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
-# Tcl_Obj *const objv[], int flags)
-#}
-#declare 66 {
-# int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc)
-#}
-#declare 67 {
-# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
-#}
-# Replaced by Tcl_FSAccess in 8.4:
-#declare 68 {
-# int TclpAccess(const char *path, int mode)
-#}
declare 69 {
- char *TclpAlloc(unsigned int size)
+ void *TclpAlloc(unsigned int size)
}
-#declare 70 {
-# int TclpCopyFile(const char *source, const char *dest)
-#}
-#declare 71 {
-# int TclpCopyDirectory(const char *source, const char *dest,
-# Tcl_DString *errorPtr)
-#}
-#declare 72 {
-# int TclpCreateDirectory(const char *path)
-#}
-#declare 73 {
-# int TclpDeleteFile(const char *path)
-#}
declare 74 {
- void TclpFree(char *ptr)
+ void TclpFree(void *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
@@ -314,62 +180,20 @@ declare 75 {
declare 76 {
unsigned long TclpGetSeconds(void)
}
-
-# deprecated
-declare 77 {
+declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
-# Removed in 8.6:
-#declare 78 {
-# int TclpGetTimeZone(unsigned long time)
-#}
-# Replaced by Tcl_FSListVolumes in 8.4:
-#declare 79 {
-# int TclpListVolumes(Tcl_Interp *interp)
-#}
-# Replaced by Tcl_FSOpenFileChannel in 8.4:
-#declare 80 {
-# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
-# char *modeString, int permissions)
-#}
declare 81 {
- char *TclpRealloc(char *ptr, unsigned int size)
+ void *TclpRealloc(void *ptr, TCL_HASH_TYPE size)
}
-#declare 82 {
-# int TclpRemoveDirectory(const char *path, int recursive,
-# Tcl_DString *errorPtr)
-#}
-#declare 83 {
-# int TclpRenameFile(const char *source, const char *dest)
-#}
-# Removed in 8.1:
-# declare 84 {
-# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr,
-# ParseValue *pvPtr)
-# }
-# declare 85 {
-# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags,
-# char **termPtr, ParseValue *pvPtr)
-# }
-# declare 86 {
-# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
-# int flags, char **termPtr, ParseValue *pvPtr)
-# }
-# declare 87 {
-# void TclPlatformInit(Tcl_Interp *interp)
-# }
-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 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
-# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
-# declare 90 {
-# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
-# }
declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
@@ -379,17 +203,8 @@ declare 92 {
const char *procName)
}
declare 93 {
- void TclProcDeleteProc(ClientData clientData)
+ void TclProcDeleteProc(void *clientData)
}
-# Removed in 8.5:
-#declare 94 {
-# int TclProcInterpProc(void *clientData, Tcl_Interp *interp,
-# int argc, const char **argv)
-#}
-# Replaced by Tcl_FSStat in 8.4:
-#declare 95 {
-# int TclpStat(const char *path, Tcl_StatBuf *buf)
-#}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
const char *newName)
@@ -400,18 +215,8 @@ declare 97 {
declare 98 {
int TclServiceIdle(void)
}
-# Removed in 8.4b2:
-#declare 99 {
-# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
-# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
-#}
-# Removed in 8.4b2:
-#declare 100 {
-# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
-# Tcl_Obj *objPtr, int flags)
-#}
declare 101 {
- CONST86 char *TclSetPreInitScript(const char *string)
+ const char *TclSetPreInitScript(const char *string)
}
declare 102 {
void TclSetupEnv(Tcl_Interp *interp)
@@ -420,19 +225,9 @@ 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)
}
-# Replaced by Tcl_FSStat in 8.4:
-#declare 105 {
-# int TclStat(const char *path, Tcl_StatBuf *buf)
-#}
-#declare 106 {
-# int TclStatDeleteProc(TclStatProc_ *proc)
-#}
-#declare 107 {
-# int TclStatInsertProc(TclStatProc_ *proc)
-#}
declare 108 {
void TclTeardownNamespace(Namespace *nsPtr)
}
@@ -442,10 +237,6 @@ declare 109 {
declare 110 {
int TclSockMinimumBuffers(void *sock, int size)
}
-# Removed in 8.1:
-# declare 110 {
-# char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
-# }
# Procedures used in conjunction with Tcl namespaces. They are
# defined here instead of in tcl.decls since they are not stable yet.
@@ -456,26 +247,26 @@ declare 111 {
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ 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)
+ Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
+ void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 {
- void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
+ void TclDeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ 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,
+ 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,
+ Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
@@ -491,28 +282,28 @@ declare 120 {
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
declare 122 {
- Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+ Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+ void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 {
- Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
}
declare 125 {
- Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
+ 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,
+ int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
@@ -530,44 +321,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)
}
-# Removed in 8.5
-#declare 134 {
-# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
-# const struct tm *t, int useGMT)
-#}
-#declare 135 {
-# int TclpCheckStackSpace(void)
-#}
-
-# Added in 8.1:
-
-#declare 137 {
-# int TclpChdir(const char *dirName)
-#}
declare 138 {
- CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
+ const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
-#declare 139 {
-# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
-# char *sym2, Tcl_PackageInitProc **proc1Ptr,
-# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr)
-#}
-#declare 140 {
-# int TclLooksLikeInt(const char *bytes, int length)
-#}
# 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,
@@ -592,9 +361,6 @@ declare 148 {
declare 149 {
void TclHandleRelease(TclHandle handle)
}
-
-# Added for Tcl 8.2
-
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
@@ -608,17 +374,6 @@ declare 152 {
declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
-
-# moved to tclTest.c (static) in 8.3.2/8.4a2
-#declare 154 {
-# int TclTestChannelCmd(void *clientData,
-# Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 155 {
-# int TclTestChannelEventCmd(void *clientData,
-# Tcl_Interp *interp, int argc, char **argv)
-#}
-
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
@@ -626,27 +381,19 @@ 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)
}
-#declare 160 {
-# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
-# Tcl_DString *dirPtr, char *pattern, char *tail,
-# GlobTypeData *types)
-#}
-# new in 8.3.2/8.4a2
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
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
@@ -677,13 +424,10 @@ declare 166 {
int 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
@@ -703,23 +447,10 @@ declare 171 {
declare 172 {
int TclInThreadExit(void)
}
-
-# added for 8.4.2
-
declare 173 {
int TclUniCharMatch(const Tcl_UniChar *string, int strLen,
const Tcl_UniChar *pattern, int ptnLen, int flags)
}
-
-# added for 8.4.3
-
-#declare 174 {
-# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
-# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
-#}
-
-# Factoring out of trace code
-
declare 175 {
int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
const char *part1, const char *part2, int flags, int leaveErrMsg)
@@ -731,95 +462,25 @@ 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)
+ void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
declare 179 {
- Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+ Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
-
-# REMOVED
-# Allocate lists without copying arrays
-# declare 180 {
-# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
-# }
-#declare 181 {
-# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
-# const char *file, int line)
-#}
-
-# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
-
-declare 182 {
+declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
-declare 183 {
+declare 183 {deprecated {}} {
struct tm *TclpGmtime(const time_t *clock)
}
# For the new "Thread Storage" subsystem.
-### REMOVED on grounds it should never have been exposed. All these
-### functions are now either static in tclThreadStorage.c or
-### MODULE_SCOPE.
-# declare 184 {
-# void TclThreadStorageLockInit(void)
-# }
-# declare 185 {
-# void TclThreadStorageLock(void)
-# }
-# declare 186 {
-# void TclThreadStorageUnlock(void)
-# }
-# declare 187 {
-# void TclThreadStoragePrint(FILE *outFile, int flags)
-# }
-# declare 188 {
-# Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id)
-# }
-# declare 189 {
-# Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved)
-# }
-# declare 190 {
-# void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 191 {
-# void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 192 {
-# void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data)
-# }
-# declare 193 {
-# void TclFinalizeThreadStorageThread(Tcl_ThreadId id)
-# }
-# declare 194 {
-# void TclFinalizeThreadStorage(void)
-# }
-# declare 195 {
-# void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 196 {
-# void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr)
-# }
-
-#
-# Added in tcl8.5a5 for compiler/executor experimentation.
-# Disabled in Tcl 8.5.1; experiments terminated. :/
-#
-#declare 197 {
-# int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
-# const CmdFrame *invoker, int word)
-#}
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
-
-#declare 199 {
-# int TclMatchIsTrivial(const char *pattern)
-#}
-
# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
@@ -888,8 +549,6 @@ declare 218 {
declare 224 {
TclPlatformType *TclGetPlatform(void)
}
-
-#
declare 225 {
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
@@ -901,12 +560,6 @@ declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
-# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
-# core and NRE-enabled
-# declare 228 {
-# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
-# int skip, ProcErrorProc *errorProc)
-# }
declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
const char *myName, int myFlags, int index)
@@ -938,10 +591,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)
}
@@ -953,7 +603,7 @@ 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 TclNRInterpProc(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 239 {
@@ -995,7 +645,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 {
@@ -1004,13 +654,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, int length, int flags)
}
# Exporting of the internal API to variables.
@@ -1038,14 +688,25 @@ declare 256 {
int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
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)
}
+# TIP 431: temporary directory creation function
+declare 258 {
+ Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj)
+}
+
+# TIP 625: for unit testing - create list objects with span
+declare 260 {
+ Tcl_Obj *TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace)
+}
+
+# TIP 625: for unit testing - check list invariants
declare 261 {
- void TclUnusedStubEntry(void)
+ void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
}
##############################################################################
@@ -1075,14 +736,9 @@ declare 3 win {
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 5 win {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
-# Removed in 8.1:
-# declare 5 win {
-# HINSTANCE TclWinLoadLibrary(char *name)
-# }
declare 6 win {
unsigned short TclWinNToHS(unsigned short ns)
}
@@ -1096,14 +752,9 @@ declare 8 win {
declare 9 win {
int TclWinGetPlatformId(void)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(TclDIR *dir)
}
-# Removed in 8.3.1 (for Win32s only)
-#declare 10 win {
-# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
-#}
# Pipe channel functions
@@ -1125,18 +776,9 @@ declare 15 win {
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 16 win {
int TclpIsAtty(int fd)
}
-# Signature changed in 8.1:
-# declare 16 win {
-# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
-# }
-# declare 17 win {
-# char *TclpGetTZName(void)
-# }
-# new for 8.5.12+ Cygwin only
declare 17 win {
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
@@ -1150,42 +792,21 @@ declare 19 win {
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
-# new for 8.4.20+/8.5.12+
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
-# removed permanently for 8.4
-#declare 21 win {
-# void TclpAsyncMark(Tcl_AsyncHandler async)
-#}
-
-# Added in 8.1:
declare 22 win {
TclFile TclpCreateTempFile(const char *contents)
}
-# Removed in 8.6:
-#declare 23 win {
-# char *TclpGetTZName(int isdst)
-#}
declare 24 win {
char *TclWinNoBackslash(char *path)
}
-# replaced by generic TclGetPlatform
-#declare 25 win {
-# TclPlatformType *TclWinGetPlatform(void)
-#}
declare 26 win {
void TclWinSetInterfaces(int wide)
}
-
-# Added in Tcl 8.3.3 / 8.4
-
declare 27 win {
void TclWinFlushDirtyChannels(void)
}
-
-# Added in 8.4.2
-
declare 28 win {
void TclWinResetInterfaces(void)
}
@@ -1284,7 +905,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 6ff5527..d3b2548 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
@@ -48,12 +89,7 @@
#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 +118,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 +141,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 +185,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 +273,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 +290,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 +320,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 +356,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 +367,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 +405,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 +425,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 +456,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 +513,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 +543,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 +562,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 +642,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
@@ -911,9 +947,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,
@@ -926,7 +962,7 @@ typedef struct CompiledLocal {
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
- * is marked by a unique ClientData tag during
+ * is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If
@@ -945,7 +981,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 +992,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 +1020,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. */
@@ -1039,7 +1075,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 +1098,8 @@ typedef struct AssocData {
*/
typedef struct LocalCache {
- int refCount;
- int numVars;
+ Tcl_Size refCount;
+ Tcl_Size numVars;
Tcl_Obj *varName0;
} LocalCache;
@@ -1083,7 +1119,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 +1133,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 +1147,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 by the
- * compiler including arguments. */
+ 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 +1177,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
@@ -1169,7 +1209,7 @@ typedef struct CmdFrame {
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 nline;
CallFrame *framePtr; /* Procedure activation record, may be
* NULL. */
struct CmdFrame *nextPtr; /* Link to calling frame. */
@@ -1213,7 +1253,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 +1263,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,7 +1301,7 @@ 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.
* The table is allocated as part of the
@@ -1301,17 +1341,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 +1392,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 +1429,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 +1442,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 +1484,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 +1534,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 +1552,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 +1569,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 +1580,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 +1591,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 +1610,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 +1676,24 @@ typedef struct Command {
* recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
- int refCount; /* 1 if in command hash table 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,18 +1711,18 @@ typedef struct Command {
/*
* Flag bits for commands.
*
- * CMD_IS_DELETED - Means that 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.
- * CMD_TRACE_ACTIVE - 1 means that trace processing is currently
+ * CMD_TRACE_ACTIVE - If 1 the trace processing is currently
* underway for a rename/delete change. See the
* two flags below for which is currently being
* processed.
- * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one
+ * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one
* execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
- * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that
+ * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that
* can handle expansion (provided it is not the
* first word).
* TCL_TRACE_RENAME - A rename trace is in progress. Further
@@ -1685,7 +1732,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 +1805,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 +1863,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 {
@@ -1824,18 +1874,17 @@ typedef struct Interp {
* contains one optimizer, which can be
* selectively overridden by extensions. */
} extra;
-
/*
* Information related to procedures and variables. See tclProc.c and
* 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
@@ -1858,6 +1907,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. */
@@ -1865,6 +1915,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.
@@ -1882,7 +1937,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
@@ -1894,7 +1949,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
@@ -1926,8 +1981,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. */
@@ -1940,7 +1999,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. */
@@ -1970,7 +2029,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
@@ -2006,9 +2065,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;
@@ -2303,22 +2362,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
@@ -2363,66 +2441,190 @@ 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_) \
+ ((int)(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)
+/*
+ * Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
+ * is shared. Note by intent this only checks for sharing of ListStore,
+ * not spans.
+ */
+#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1)
+
+/*
+ * Certain commands like concat are optimized if an existing string
+ * representation of a list object is known to be in canonical format (i.e.
+ * generated from the list representation). There are three conditions when
+ * this will be the case:
+ * (1) No string representation exists which means it will obviously have
+ * to be generated from the list representation when needed
+ * (2) The ListStore flags is marked canonical. This is done at the time
+ * the string representation is generated from the list IF the list
+ * representation does not have a span (see comments in UpdateStringOfList).
+ * (3) The list representation does not have a span component. This is
+ * because list Tcl_Obj's with spans are always created from existing lists
+ * and never from strings (see SetListFromAny) and thus their string
+ * representation will always be canonical.
+ */
+#define ListObjIsCanonical(listObj_) \
+ (((listObj_)->bytes == NULL) \
+ || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \
+ || ListObjSpanPtr(listObj_) != NULL)
-#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\
- : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+/*
+ * 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_)))
-#define TclListObjLength(interp, listPtr, lenPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
- : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+/*
+ * 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(listPtr) \
- (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
+#define TclListObjIsCanonical(listObj_) \
+ (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
@@ -2433,40 +2635,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) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
@@ -2476,21 +2683,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) : \
- 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) : \
+ ? (*(wideIntPtr) = \
+ ((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Flag values for TclTraceDictPath().
@@ -2533,7 +2730,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);
@@ -2567,10 +2764,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,
@@ -2596,8 +2795,10 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp,
*----------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
typedef Tcl_CmdProc *TclCmdProcType;
typedef Tcl_ObjCmdProc *TclObjCmdProcType;
+#endif
/*
*----------------------------------------------------------------
@@ -2605,7 +2806,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
*----------------------------------------------------------------
*/
-typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
+typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
@@ -2617,9 +2818,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. */
@@ -2655,18 +2856,23 @@ 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_) & ENCODING_PROFILE_MASK)
+#define ENCODING_PROFILE_SET(flags_, profile_) \
+ do { \
+ (flags_) &= ~ENCODING_PROFILE_MASK; \
+ (flags_) |= profile_; \
+ } while (0)
/*
*----------------------------------------------------------------
@@ -2678,9 +2884,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 int
+TclEncodingProfileNameToId(Tcl_Interp *interp,
+ const char *profileName,
+ int *profilePtr);
+MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp,
+ int profileId);
+MODULE_SCOPE int TclEncodingSetProfileFlags(int flags);
+MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp);
/*
* TIP #233 (Virtualized Time)
@@ -2689,7 +2906,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.
@@ -2700,17 +2917,14 @@ 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 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;
@@ -2731,10 +2945,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 */
/*
@@ -2743,7 +2957,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 {
@@ -2806,7 +3019,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
@@ -2816,7 +3029,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
@@ -2830,29 +3043,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 */
/*
*----------------------------------------------------------------
@@ -2879,11 +3082,14 @@ 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);
+MODULE_SCOPE double TclCeil(const void *a);
MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan);
MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
@@ -2895,6 +3101,8 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
+MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
@@ -2904,25 +3112,20 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE int TclConvertElement(const char *src, int length,
char *dst, int flags);
-MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
- Tcl_Interp *interp,
- const char *cmdName,
- Tcl_Namespace *nsPtr,
- Tcl_ObjCmdProc *proc,
- ClientData clientData,
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp,
+ const char *cmdName, Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc);
-MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *nameNamespacePtr,
- Tcl_Namespace *ensembleNamespacePtr,
- int flags);
+MODULE_SCOPE 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 **elementPtr, const char **nextPtr,
int *sizePtr, int *literalPtr);
-/* TIP #280 - Modified token based evulation, with line information. */
+/* 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);
@@ -2933,22 +3136,23 @@ 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,
+MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int *objcPtr);
MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr);
-
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
@@ -2966,23 +3170,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);
-
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp,
+ const char *cmdName, Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc,
+ void *clientData, Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
@@ -2994,9 +3194,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);
@@ -3004,25 +3203,22 @@ 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,
Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
-MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd;
MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);
-MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd;
MODULE_SCOPE void TclInitAlloc(void);
MODULE_SCOPE void TclInitDbCkalloc(void);
MODULE_SCOPE void TclInitDoubleConversion(void);
@@ -3034,11 +3230,17 @@ 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 TclIsDigitProc(int byte);
MODULE_SCOPE int TclIsBareword(int byte);
MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[],
int forceRelative);
+MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user,
+ const char *subPath, Tcl_DString *dsPtr);
+MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user);
+MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp,
+ Tcl_Obj *pathObj);
+MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj);
MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result);
MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp,
@@ -3049,6 +3251,11 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n,
int *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, int elemCount,
+ Tcl_Obj *const elemObjv[]);
+MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ int fromIdx, int 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,
@@ -3056,6 +3263,7 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
const EnsembleImplMap map[]);
+MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp);
MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes,
const char **endPtr);
MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
@@ -3064,7 +3272,6 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int TclNokia770Doubles(void);
MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
-MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr);
MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const char *operation,
@@ -3076,6 +3283,8 @@ 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);
+MODULE_SCOPE int TclParseHex(const char *src, int numBytes,
+ int *resultPtr);
MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
const char *expected, const char *bytes,
int numBytes, const char **endPtrPtr, int flags);
@@ -3086,25 +3295,41 @@ 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);
+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,
+ Tcl_ThreadCreateProc *proc, void *clientData,
int stackSize, int flags);
MODULE_SCOPE int TclpFindVariable(const char *name, int *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);
@@ -3123,7 +3348,7 @@ MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp,
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);
@@ -3131,6 +3356,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,
@@ -3139,7 +3367,7 @@ 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);
@@ -3147,13 +3375,14 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
int 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, int 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);
@@ -3165,17 +3394,16 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
-
typedef int (*memCmpFn_t)(const void*, const void*, size_t);
-MODULE_SCOPE int TclStringCmp (Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
+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 TclStringCmpOpts(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int *nocase,
+ int *reqlength);
MODULE_SCOPE int TclStringMatch(const char *str, int 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,
struct CompileEnv *envPtr);
@@ -3193,26 +3421,23 @@ 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);
+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
+MODULE_SCOPE int TclUtfCount(int ch);
+#if TCL_UTF_MAX > 3
+# define TclUtfToUCS4 Tcl_UtfToUniChar
# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
+# define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src))
+#else
+ MODULE_SCOPE int TclUtfToUCS4(const char *, int *);
+ MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *);
+ MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *);
#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 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,
@@ -3228,35 +3453,69 @@ 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);
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);
+/* Tip 430 */
+MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
+
+
+#if TCL_UTF_MAX > 3
+ 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);
+# 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
+#else
+# define tclUniCharStringType tclStringType
+# define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj
+# define TclNewUnicodeObj Tcl_NewUnicodeObj
+# define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj
+# define TclUniCharNcasecmp Tcl_UniCharNcasecmp
+# define TclUniCharCaseMatch Tcl_UniCharCaseMatch
+# define TclUniCharNcmp Tcl_UniCharNcmp
+# undef TclNumUtfChars
+# define TclNumUtfChars Tcl_NumUtfChars
+# undef TclGetCharLength
+# define TclGetCharLength Tcl_GetCharLength
+# undef TclUtfAtIndex
+# define TclUtfAtIndex Tcl_UtfAtIndex
+# undef TclGetRange
+# define TclGetRange Tcl_GetRange
+# undef TclGetUniChar
+# define TclGetUniChar Tcl_GetUniChar
+#endif
-MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
/*
* Many parsing tasks need a common definition of whitespace.
@@ -3274,59 +3533,31 @@ MODULE_SCOPE int TclIsSpaceProc(int byte);
*----------------------------------------------------------------
*/
-MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_AfterObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_AppendObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd;
MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+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);
-MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclChanCreateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd;
MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
-MODULE_SCOPE int TclClockOldscanObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd;
+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);
-MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+ void *clientData);
+MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd;
MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, Tcl_Obj *part1Ptr,
@@ -3334,234 +3565,91 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
Tcl_Obj *const pathv[], Tcl_Obj *keysPtr);
MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
int pathc, Tcl_Obj *const pathv[]);
-MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd;
/* Assemble command function */
-MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+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 int Tcl_EofObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FconfigureObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd;
+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 int Tcl_FileEventObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FileEventObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FlushObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForeachObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_FormatObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_GetsObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobalObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_IfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_IncrObjCmd;
MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData,
- Tcl_Interp *interp, int argc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+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);
-MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNamespaceEnsembleCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_OpenObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PackageObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PidObjCmd;
MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PutsObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_PwdObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReadObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegexpObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegsubObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RenameObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_RepresentationCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReturnObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ScanObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SeekObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SetObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SplitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SocketObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SourceObjCmd;
MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp);
-MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SubstObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_SwitchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TellObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_ThrowObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeRateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TraceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_TryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnloadObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnsetObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpdateObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpvarObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_VariableObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_VwaitObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_WhileObjCmd;
/*
*----------------------------------------------------------------
@@ -3614,6 +3702,9 @@ MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3776,6 +3867,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3885,105 +3979,71 @@ MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclInvertOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInvertOpCmd;
MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclNotOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNotOpCmd;
MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclAddOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclAddOpCmd;
MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclMulOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclMulOpCmd;
MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclAndOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclAndOpCmd;
MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclOrOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclOrOpCmd;
MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclXorOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclXorOpCmd;
MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclPowOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclPowOpCmd;
MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclLshiftOpCmd;
MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclRshiftOpCmd;
MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclModOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclModOpCmd;
MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclNeqOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNeqOpCmd;
MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclStrneqOpCmd;
MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclInOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclInOpCmd;
MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclNiOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclNiOpCmd;
MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclMinusOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclMinusOpCmd;
MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclDivOpCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_ObjCmdProc TclDivOpCmd;
MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -4005,12 +4065,47 @@ MODULE_SCOPE int TclCompileEqOpCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrLtOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrLeOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrGtOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStrGeOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
/*
+ * Routines that provide the [string] ensemble functionality. Possible
+ * candidates for public interface.
+ */
+
+MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags);
+MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int start);
+MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int last);
+MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int count, int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int first, int 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.
@@ -4061,11 +4156,55 @@ 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].
*/
@@ -4074,13 +4213,40 @@ 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);
-
/* 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);
+ }
+}
/*
*----------------------------------------------------------------
@@ -4139,7 +4305,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)
@@ -4147,7 +4313,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.
*/
@@ -4156,10 +4322,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 { \
@@ -4167,6 +4333,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)
/*
@@ -4177,14 +4347,14 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
*/
# define TclAllocObjStorageEx(interp, objPtr) \
- (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
+ (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
@@ -4198,6 +4368,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 *);
/*
@@ -4248,7 +4419,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
@@ -4302,25 +4473,32 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
/*
*----------------------------------------------------------------
* 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:
+ * 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 "prototype" for this macro is:
*
- * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len);
+ * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
*
- * This macro should only be called on an unshared objPtr where
- * objPtr->typePtr->freeIntRepProc == NULL
*----------------------------------------------------------------
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} 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); \
}
@@ -4338,12 +4516,13 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclGetString(objPtr) \
- ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
+ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
+#undef TclGetStringFromObj
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
- : Tcl_GetStringFromObj((objPtr), (lenPtr)))
+ : (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
/*
*----------------------------------------------------------------
@@ -4351,11 +4530,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); \
@@ -4363,6 +4542,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.
@@ -4376,18 +4559,68 @@ 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; \
} \
} 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).
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
#define TclHasStringRep(objPtr) \
((objPtr)->bytes != NULL)
/*
*----------------------------------------------------------------
+ * 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:
@@ -4434,19 +4667,19 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
allocated = TCL_MAX_TOKENS; \
} \
newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \
- (unsigned int) (allocated * sizeof(Tcl_Token))); \
+ allocated * sizeof(Tcl_Token)); \
if (newPtr == NULL) { \
allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \
if (allocated > TCL_MAX_TOKENS) { \
allocated = TCL_MAX_TOKENS; \
} \
newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \
- (unsigned int) (allocated * sizeof(Tcl_Token))); \
+ allocated * sizeof(Tcl_Token)); \
} \
(available) = allocated; \
if (oldPtr == NULL) { \
memcpy(newPtr, staticPtr, \
- (size_t) ((used) * sizeof(Tcl_Token))); \
+ (used) * sizeof(Tcl_Token)); \
} \
(tokenPtr) = newPtr; \
} \
@@ -4469,10 +4702,17 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
+#if TCL_UTF_MAX > 3
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToUniChar(str, chPtr))
+#else
+#define TclUtfToUniChar(str, chPtr) \
+ (((UCHAR(*(str))) < 0x80) ? \
+ ((*(chPtr) = UCHAR(*(str))), 1) \
+ : Tcl_UtfToChar16(str, chPtr))
+#endif
/*
*----------------------------------------------------------------
@@ -4481,28 +4721,23 @@ 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,
+ * MODULE_SCOPE void TclNumUtfCharsM(int numChars, const char *bytes,
* int numBytes);
*----------------------------------------------------------------
*/
-#define TclNumUtfChars(numChars, bytes, numBytes) \
+#define TclNumUtfCharsM(numChars, bytes, numBytes) \
do { \
int _count, _i = (numBytes); \
unsigned char *_str = (unsigned char *) (bytes); \
while (_i && (*_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
@@ -4518,31 +4753,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 */
/*
*----------------------------------------------------------------
@@ -4569,7 +4787,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------------
*/
-MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
+MODULE_SCOPE Tcl_LibraryInitProc TclTommath_Init;
/*
*----------------------------------------------------------------------
@@ -4581,11 +4799,13 @@ 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;
+
+
/*
*----------------------------------------------------------------
@@ -4606,51 +4826,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)
/*
@@ -4659,38 +4853,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, int 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 { \
@@ -4714,14 +4918,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)
@@ -4735,7 +4951,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* sizeof(sLiteral "") will fail to compile otherwise.
*/
#define TclNewLiteralStringObj(objPtr, sLiteral) \
- TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+ TclNewStringObj((objPtr), (sLiteral), sizeof(sLiteral "") - 1)
/*
*----------------------------------------------------------------
@@ -4748,41 +4964,35 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#define TclDStringAppendLiteral(dsPtr, sLiteral) \
- Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+ Tcl_DStringAppend((dsPtr), (sLiteral), sizeof(sLiteral "") - 1)
#define TclDStringClear(dsPtr) \
Tcl_DStringSetLength((dsPtr), 0)
/*
*----------------------------------------------------------------
* 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
/*
@@ -4802,10 +5012,30 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* the internal stubs, but the core can use the macro instead.
*/
-#define TclCleanupCommandMacro(cmdPtr) \
- if ((cmdPtr)->refCount-- <= 1) { \
- ckfree((char *) (cmdPtr));\
- }
+#define TclCleanupCommandMacro(cmdPtr) \
+ do { \
+ if ((cmdPtr)->refCount-- <= 1) { \
+ ckfree(cmdPtr); \
+ } \
+ } 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)
/*
*----------------------------------------------------------------
@@ -4868,12 +5098,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
- memPtr = (ClientData) (_objPtr); \
+ *(void **)&(memPtr) = (void *) (_objPtr); \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
- TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
+ TclFreeObjStorageEx((interp), (Tcl_Obj *)(memPtr)); \
TclIncrObjsFreed(); \
} while (0)
@@ -4883,12 +5113,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
- memPtr = (ClientData) _objPtr; \
+ *(void **)&(memPtr) = (void *)_objPtr; \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
- Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \
+ Tcl_Obj *_objPtr = (Tcl_Obj *)(memPtr); \
_objPtr->bytes = NULL; \
_objPtr->typePtr = NULL; \
_objPtr->refCount = 1; \
@@ -4932,7 +5162,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;
@@ -4947,10 +5177,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)
@@ -4962,7 +5192,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
@@ -4973,7 +5203,7 @@ 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(size) TclpAlloc(size)
@@ -4982,11 +5212,32 @@ typedef struct NRE_callback {
#endif
/*
+ * Special hack for macOS, where the static linker (technically the 'ar'
+ * command) hates empty object files, and accepts no flags to make it shut up.
+ *
+ * These symbols are otherwise completely useless.
+ *
+ * They can't be written to or written through. They can't be seen by any
+ * other code. They use a separate attribute (supported by all macOS
+ * compilers, which are derivatives of clang or gcc) to stop the compilation
+ * from moaning. They will be excluded during the final linking stage.
+ *
+ * Other platforms get nothing at all. That's good.
+ */
+
+#ifdef MAC_OSX_TCL
+#define TCL_MAC_EMPTY_FILE(name) \
+ static __attribute__((used)) const void *const TclUnusedFile_ ## name = NULL;
+#else
+#define TCL_MAC_EMPTY_FILE(name)
+#endif /* MAC_OSX_TCL */
+
+/*
* Other externals.
*/
-MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
- * (if changed with tcl-env). */
+MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
+ * (if changed with tcl-env). */
#endif /* _TCLINT */
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index e958733..e4c0b19 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
@@ -74,7 +75,8 @@ EXTERN void TclCleanupCommand(Command *cmdPtr);
EXTERN int TclCopyAndCollapse(int 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 */
@@ -94,7 +96,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);
@@ -112,7 +114,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp,
/* 23 */
EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName);
/* 24 */
-EXTERN int TclFormatInt(char *buffer, long n);
+EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n);
/* 25 */
EXTERN void TclFreePackageInfo(Interp *iPtr);
/* Slot 26 is reserved */
@@ -128,7 +130,8 @@ 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 */
@@ -150,9 +153,10 @@ 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 */
+/* 43 */
+EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void);
/* 44 */
EXTERN int TclGuessPackageName(const char *fileName,
Tcl_DString *bufPtr);
@@ -170,11 +174,11 @@ EXTERN void TclInitCompiledLocals(Tcl_Interp *interp,
EXTERN int TclInterpInit(Tcl_Interp *interp);
/* Slot 52 is reserved */
/* 53 */
-EXTERN int TclInvokeObjectCommand(ClientData clientData,
+EXTERN int TclInvokeObjectCommand(void *clientData,
Tcl_Interp *interp, int argc,
- CONST84 char **argv);
+ const char **argv);
/* 54 */
-EXTERN int TclInvokeStringCommand(ClientData clientData,
+EXTERN int TclInvokeStringCommand(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 55 */
@@ -194,7 +198,7 @@ EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr);
/* 62 */
EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr);
/* 63 */
-EXTERN int TclObjInterpProc(ClientData clientData,
+EXTERN int TclObjInterpProc(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 64 */
@@ -205,24 +209,25 @@ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc,
/* Slot 67 is reserved */
/* Slot 68 is reserved */
/* 69 */
-EXTERN char * TclpAlloc(unsigned int size);
+EXTERN void * TclpAlloc(unsigned int 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 +235,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 +251,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 +265,15 @@ EXTERN int TclServiceIdle(void);
/* Slot 99 is reserved */
/* Slot 100 is reserved */
/* 101 */
-EXTERN CONST86 char * TclSetPreInitScript(const char *string);
+EXTERN 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 */
@@ -283,22 +290,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 112 */
-EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
+EXTERN 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,
+EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
+ const char *name, void *clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 114 */
-EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
+EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr);
/* 115 */
-EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN 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,
+EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 117 */
-EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
+EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 118 */
@@ -313,23 +320,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 121 */
-EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
+EXTERN int TclForgetImport(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
-EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
+EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 123 */
-EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
+EXTERN void TclGetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
/* 124 */
-EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp);
/* 125 */
-EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
+EXTERN 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,
+EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
@@ -347,25 +354,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);
@@ -400,15 +407,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);
@@ -421,9 +430,11 @@ EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int 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);
@@ -456,16 +467,18 @@ 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,
+EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr,
const char *encodingName);
/* 179 */
-EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
+EXTERN 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 */
@@ -568,13 +581,13 @@ 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,
+ int objc, Tcl_Obj *const objv[]);
/* 239 */
EXTERN int TclNRInterpProcCore(Tcl_Interp *interp,
Tcl_Obj *procNameObj, int skip,
@@ -605,15 +618,15 @@ 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,
+EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes,
int length, int flags);
/* 252 */
EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
@@ -638,15 +651,20 @@ 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);
-/* Slot 258 is reserved */
+ Tcl_LibraryInitProc *initProc,
+ Tcl_LibraryInitProc *safeInitProc);
+/* 258 */
+EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj);
/* Slot 259 is reserved */
-/* Slot 260 is reserved */
+/* 260 */
+EXTERN Tcl_Obj * TclListTestObj(size_t length, size_t leadingSpace,
+ size_t endSpace);
/* 261 */
-EXTERN void TclUnusedStubEntry(void);
+EXTERN void TclListObjValidate(Tcl_Interp *interp,
+ Tcl_Obj *listObj);
typedef struct TclIntStubs {
int magic;
@@ -660,13 +678,13 @@ typedef struct TclIntStubs {
int (*tclCleanupChildren) (Tcl_Interp *interp, int 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 */
+ TCL_DEPRECATED_API("") 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 */
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);
@@ -676,7 +694,7 @@ typedef struct TclIntStubs {
void (*reserved21)(void);
int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */
Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */
- int (*tclFormatInt) (char *buffer, long n); /* 24 */
+ int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
@@ -686,7 +704,7 @@ 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 */
@@ -694,8 +712,8 @@ typedef struct TclIntStubs {
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 */
- void (*reserved43)(void);
+ const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
+ Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */
int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
@@ -705,8 +723,8 @@ typedef struct TclIntStubs {
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 */
+ int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */
+ int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
void (*reserved57)(void);
@@ -715,37 +733,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 (*tclObjInterpProc) (void *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 */
void (*reserved65)(void);
void (*reserved66)(void);
void (*reserved67)(void);
void (*reserved68)(void);
- char * (*tclpAlloc) (unsigned int size); /* 69 */
+ void * (*tclpAlloc) (unsigned int 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 */
@@ -753,10 +771,10 @@ typedef struct TclIntStubs {
int (*tclServiceIdle) (void); /* 98 */
void (*reserved99)(void);
void (*reserved100)(void);
- CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
+ 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);
@@ -764,37 +782,37 @@ typedef struct TclIntStubs {
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
int (*tclSockMinimumBuffers) (void *sock, int 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 */
+ int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
+ Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
+ void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
+ int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
+ Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
+ 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 */
+ int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
+ Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
+ void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
+ Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */
+ 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 */
+ 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 */
@@ -810,17 +828,17 @@ typedef struct TclIntStubs {
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 */
+ 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 */
@@ -830,12 +848,12 @@ typedef struct TclIntStubs {
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 */
+ void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ 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);
@@ -888,9 +906,9 @@ 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 (*tclNRInterpProc) (void *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 (*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 */
@@ -900,20 +918,20 @@ typedef struct TclIntStubs {
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int 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, int 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 (*reserved258)(void);
+ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
+ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
void (*reserved259)(void);
- void (*reserved260)(void);
- void (*tclUnusedStubEntry) (void); /* 261 */
+ Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 260 */
+ void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
@@ -996,7 +1014,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
#define TclpGetUserHome \
(tclIntStubsPtr->tclpGetUserHome) /* 42 */
-/* Slot 43 is reserved */
+#define TclGetObjInterpProc2 \
+ (tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */
#define TclGuessPackageName \
(tclIntStubsPtr->tclGuessPackageName) /* 44 */
#define TclHideUnsafeCommands \
@@ -1101,38 +1120,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 \
@@ -1223,10 +1242,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 \
@@ -1341,8 +1360,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 \
@@ -1355,13 +1374,15 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
#define TclPtrUnsetVar \
(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
-#define TclStaticPackage \
- (tclIntStubsPtr->tclStaticPackage) /* 257 */
-/* Slot 258 is reserved */
+#define TclStaticLibrary \
+ (tclIntStubsPtr->tclStaticLibrary) /* 257 */
+#define TclpCreateTemporaryDirectory \
+ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
/* Slot 259 is reserved */
-/* Slot 260 is reserved */
-#define TclUnusedStubEntry \
- (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */
+#define TclListTestObj \
+ (tclIntStubsPtr->tclListTestObj) /* 260 */
+#define TclListObjValidate \
+ (tclIntStubsPtr->tclListObjValidate) /* 261 */
#endif /* defined(USE_TCL_STUBS) */
@@ -1370,63 +1391,42 @@ 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 TclGuessPackageName
#undef TclUnusedStubEntry
+#undef TclSetPreInitScript
#undef TclObjInterpProc
#define TclObjInterpProc TclGetObjInterpProc()
-
-#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 */
+#define TclObjInterpProc2 TclGetObjInterpProc2()
+#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..07888bf 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,
@@ -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 */
@@ -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) ((int)(size_t)(pid))
#endif
#endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 0a57b70..cacf87a 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
@@ -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);
@@ -254,8 +252,6 @@ static int ChildInvokeHidden(Tcl_Interp *interp,
int 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,
@@ -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, -1, 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"
@@ -400,6 +407,7 @@ Tcl_Init(
" } else {\n"
" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
" }\n"
+" lappend scripts {::tcl::zipfs::tcl_library_init}\n"
" lappend scripts {\n"
"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
"set grandParentDir [file dirname $parentDir]\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", -1, 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. */
+ ClientData 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]);
@@ -1087,7 +1111,7 @@ 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);
return TCL_ERROR;
@@ -1401,7 +1425,8 @@ TclPreventAliasLoop(
* create or rename the command.
*/
- if (cmdPtr->objProc != AliasObjCmd) {
+ if (cmdPtr->objProc != TclAliasObjCmd
+ && cmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
@@ -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,
@@ -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.
*
@@ -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,8 +1865,8 @@ AliasNRCmd(
return Tcl_NREvalObj(interp, listPtr, flags);
}
-static int
-AliasObjCmd(
+int
+TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -1919,6 +1955,73 @@ AliasObjCmd(
return result;
#undef ALIAS_CMDV_PREALLOC
}
+
+int
+TclLocalAliasObjCmd(
+ ClientData 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
+}
/*
*----------------------------------------------------------------------
@@ -2218,7 +2321,7 @@ GetInterp(
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;
}
@@ -2274,7 +2377,7 @@ ChildBgerror(
if (objc) {
int 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));
@@ -2321,7 +2424,7 @@ ChildCreate(
int isNew, 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 +2461,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 +2474,7 @@ ChildCreate(
((Interp *) parentInterp)->maxNestingDepth;
if (safe) {
- if (Tcl_MakeSafe(childInterp) == TCL_ERROR) {
+ if (TclMakeSafe(childInterp) == TCL_ERROR) {
goto error;
}
} else {
@@ -2426,7 +2529,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,8 +2543,8 @@ ChildCreate(
*----------------------------------------------------------------------
*/
-static int
-ChildObjCmd(
+int
+TclChildObjCmd(
ClientData clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -2473,7 +2576,7 @@ NRChildCmd(
};
if (childInterp == NULL) {
- Tcl_Panic("ChildObjCmd: interpreter has been deleted");
+ Tcl_Panic("TclChildObjCmd: interpreter has been deleted");
}
if (objc < 2) {
@@ -2920,7 +3023,7 @@ ChildRecursionLimit(
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(childInterp, 0);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
@@ -3156,7 +3259,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 +3276,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 +3293,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 {}}", -1, 0);
}
iPtr->flags |= SAFE_INTERP;
@@ -3209,7 +3308,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 +3324,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
@@ -3517,9 +3616,6 @@ Tcl_LimitAddHandler(
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
}
- if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) {
- deleteProc = NULL;
- }
/*
* Allocate a handler record.
@@ -4156,7 +4252,7 @@ DeleteScriptLimitCallback(
static void
CallScriptLimitCallback(
ClientData clientData,
- Tcl_Interp *interp) /* Interpreter which failed the limit */
+ TCL_UNUSED(Tcl_Interp *))
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
int code;
@@ -4437,12 +4533,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;
@@ -4470,13 +4566,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;
}
@@ -4497,7 +4593,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];
@@ -4514,7 +4610,7 @@ ChildCommandLimitCmd(
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;
}
@@ -4624,7 +4720,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)) {
@@ -4632,9 +4728,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;
@@ -4664,7 +4760,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:
@@ -4673,7 +4769,7 @@ ChildTimeLimitCmd(
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp,
- Tcl_NewLongObj(limitMoment.usec/1000));
+ Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
@@ -4695,7 +4791,7 @@ ChildTimeLimitCmd(
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) {
@@ -4706,7 +4802,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];
@@ -4723,49 +4819,41 @@ ChildTimeLimitCmd(
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);
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);
return TCL_ERROR;
}
- limitMoment.sec = sec;
+ limitMoment.sec = (long)tmp;
break;
}
- }
}
if (milliObj != NULL || secObj != NULL) {
if (milliObj != NULL) {
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 f0bd53e..bb13961 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -3,39 +3,152 @@
*
* 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"
+#include "tclArithSeries.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_) /* TODO - is there a Tcl-specific one? */
+/*
+ * LIST_INDEX_ASSERT is to catch errors with negative indices and counts
+ * being passed AFTER validation. On Tcl9 length types are unsigned hence
+ * the checks against LIST_MAX. On Tcl8 length types are signed hence the
+ * also checks against 0.
+ */
+#define LIST_INDEX_ASSERT(idxarg_) \
+ do { \
+ 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 +160,905 @@ 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)
{
- List *listRepPtr;
+ 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 */
+{
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf(
+ "list construction failed: unable to alloc %" TCL_LL_MODIFIER
+ "u bytes",
+ (Tcl_WideInt)size));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListLimitExceeded --
+ *
+ * Generates an error for exceeding maximum list size.
+ *
+ * Results:
+ * Always TCL_ERROR.
+ *
+ * Side effects:
+ * Error message and code are stored in the interpreter if not NULL.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+ListLimitExceededError(Tcl_Interp *interp)
+{
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedShiftDown --
+ *
+ * Shifts the "in-use" contents in the ListStore for a ListRep down
+ * by the given number of slots. The ListStore must be unshared and
+ * the free space at the front of the storage area must be big enough.
+ * It is the caller's responsibility to check.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The contents of the ListRep's ListStore area are shifted down in the
+ * storage area. The ListRep's ListSpan is updated accordingly.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListRepUnsharedShiftDown(ListRep *repPtr, 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) {
+ 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 %u 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 storePtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListStoreReallocate --
+ *
+ * Reallocates the memory for a ListStore.
+ *
+ * Results:
+ * Pointer to the ListStore which may be the same as storePtr or pointer
+ * to a new block of memory. On reallocation failure, NULL is returned.
+ *
+ *
+ * Side effects:
+ * The memory pointed to by storePtr is freed if it a new block has to
+ * be returned.
+ *
+ *
+ *------------------------------------------------------------------------
+ */
+ListStore *
+ListStoreReallocate (ListStore *storePtr, Tcl_Size numSlots)
+{
+ Tcl_Size newCapacity;
+ ListStore *newStorePtr;
+
+ newCapacity = ListStoreUpSize(numSlots);
+ newStorePtr =
+ (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(newCapacity));
+ if (newStorePtr == NULL) {
+ newCapacity = numSlots;
+ newStorePtr = (ListStore *)attemptckrealloc(storePtr,
+ LIST_SIZE(newCapacity));
+ if (newStorePtr == NULL)
+ return NULL;
}
- return listRepPtr;
+ /* Only the capacity has changed, fix it in the header */
+ newStorePtr->numAllocated = newCapacity;
+ 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.
*
- * Like NewListInternalRep, but additionally sets an error message on failure.
+ * The reference counts of the ListStore and ListSpan (if present)
+ * pointed to by the initialized repPtr are set to zero.
+ * Caller has to manage them as necessary.
+ *
+ * Results:
+ * On success, TCL_OK is returned with *listRepPtr initialized.
+ * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise
+ * returns TCL_ERROR with *listRepPtr fields set to NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
+static int
+ListRepInit(
+ 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 +1066,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 +1092,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 +1102,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 --
*
- * 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.
+ * This function is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
+ * as the Tcl_NewListObj function above except that it calls
+ * Tcl_DbCkalloc directly with the file name and line number from its
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
- * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead.
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
+ * result of calling Tcl_NewListObj.
+ *
+ * Results:
+ * A new list object is returned that is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The new list object has ref count 0.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -258,95 +1154,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 +1345,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.
+ * 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.
*
- * 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.
+ * 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.
*
- * Effect
- *
- * 'listPtr' is converted to a list if it isn't one already.
+ * Side effects:
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -376,84 +1364,318 @@ 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 (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ return TclArithSeriesObjCopy(interp, listObj);
+ }
+ 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;
+ ListRep listRep;
- if (listPtr->typePtr != &tclListType) {
- int result;
-
- 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 +1684,37 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * Appends the elements of elemListPtr to those of listPtr.
- *
- * Value
- *
- * TCL_OK
- *
- * Success.
+ * This function appends the elements in the list fromObj
+ * to toObj. toObj must not be shared else the function will panic.
*
- * TCL_ERROR
- *
- * '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 +1723,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 +1903,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 = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = 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.
+ * TODO - compare perf with 8.6 to see if worth optimizing single
+ * element case
*/
-
- *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;
- Tcl_IncrRefCount(objPtr);
- listRepPtr->elemCount++;
-
- /*
- * Invalidate any old string representation since the list's internal
- * representation has changed.
- */
-
- TclInvalidateStringRep(listPtr);
- return TCL_OK;
+ return TclListObjAppendElements(interp, toObj, 1, &elemObj);
}
/*
@@ -716,34 +1945,31 @@ 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;
- }
+ /*
+ * TODO
+ * Unlike the original list code, this does not optimize for lindex'ing
+ * an empty string when the internal rep is not already a list. On the
+ * other hand, this code will be faster for the case where the object
+ * is currently a dict. Benchmark the two cases.
+ */
+ if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
+ != TCL_OK) {
+ return TCL_ERROR;
}
-
- listRepPtr = ListRepPtr(listPtr);
- if ((index < 0) || (index >= listRepPtr->elemCount)) {
+ if ((index < 0) || (index >= numElems)) {
*objPtrPtr = NULL;
} else {
- *objPtrPtr = (&listRepPtr->elements)[index];
+ *objPtrPtr = elemObjs[index];
}
return TCL_OK;
@@ -754,47 +1980,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;
-
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListRep listRep;
- 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;
+ /*
+ * TODO
+ * Unlike the original list code, this does not optimize for lindex'ing
+ * an empty string when the internal rep is not already a list. On the
+ * other hand, this code will be faster for the case where the object
+ * is currently a dict. Benchmark the two cases.
+ */
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
@@ -803,285 +2030,498 @@ 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;
+ int lenChange;
+ int leadSegmentLen;
+ int tailSegmentLen;
+ Tcl_Size numFreeSlots;
+ int leadShift;
+ int 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.
- */
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
+ return TCL_ERROR; /* Cannot be converted to a list */
- listRepPtr = ListRepPtr(listPtr);
- elemPtrs = &listRepPtr->elements;
- numElems = listRepPtr->elemCount;
+ /* TODO - will need modification if Tcl9 sticks to unsigned indices */
+ /* 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 = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = 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.
- */
-
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = elemPtrs[j];
+ /* Garbage collect before checking the pure insert optimization */
+ ListRepFreeUnreferenced(&listRep);
- 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 */
-#if TCL_MAJOR_VERSION > 8
- Tcl_DecrRefCount(objv[i]);
-#else
- objv[i]->refCount--;
-#endif
- }
- 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;
+ }
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
- listRepPtr->refCount++;
+ /*
+ * 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?
+ */
- elemPtrs = &listRepPtr->elements;
+ /* 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);
- if (isShared) {
- /*
- * The old struct will remain in place; need new refCounts for the
- * new List struct references. Copy over only the surviving
- * elements.
- */
+ LIST_ASSERT((numToDelete + numToInsert) > 0);
- 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]);
- }
+ /* Base of slot array holding the list elements */
+ listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
+
+ /*
+ * Free up elements to be deleted. Before that, increment the ref counts
+ * for objects to be inserted in case there is overlap. T:listobj-11.1
+ */
+ if (numToInsert) {
+ /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
+ ObjArrayIncrRefs(insertObjs, 0, numToInsert);
+ }
+ if (numToDelete) {
+ /* T:listrep-1.{6,7,12:21},3.{19:41} */
+ ObjArrayDecrRefs(listObjs, first, numToDelete);
+ }
+
+ /*
+ * TODO - below the moves are optimized but this may result in needing a
+ * span allocation. Perhaps for small lists, it may be more efficient to
+ * just move everything up front and save on allocating a span.
+ */
+
+ /*
+ * Calculate shifts if necessary to 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.
+ */
+ int leadSpace = ListRepNumFreeHead(&listRep);
+ int tailSpace = ListRepNumFreeTail(&listRep);
+ int 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)) {
+ int 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)) {
+ int 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;
}
@@ -1090,46 +2530,49 @@ Tcl_ListObjReplace(
*
* TclLindexList --
*
- * Implements 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.
+ * This procedure handles the 'lindex' command when objc==3.
*
- * 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 specified element, with its 'refCount' incremented, or
- * NULL if an error occurred.
+ * Side effects:
+ * None.
*
- * 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);
}
/*
@@ -1144,62 +2587,83 @@ 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. why not directly return an error?
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
- {
- 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);
- }
+ ListObjGetElements(indexListCopy, numIndexObjs, indexObjs);
+ listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
- return listPtr;
+ return listObj;
}
/*
*----------------------------------------------------------------------
*
- * TclLindexFlat --
- *
- * The core of the 'lindex' command, with all index
- * arguments presented as a flat list.
+ * TclLindexFlat --
*
- * Value
+ * This procedure is the core of the 'lindex' command, with all index
+ * arguments presented as a flat list.
*
- * 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:
+ * 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.
*
- * 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_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;
+ }
- Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(listObj);
- for (i=0 ; i<indexCount && listPtr ; i++) {
- int index, listLen = 0;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ Tcl_Size index, listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
@@ -1208,18 +2672,16 @@ TclLindexFlat(
* while we are still using it. See test lindex-8.4.
*/
- sublistCopy = TclListObjCopy(interp, listPtr);
- Tcl_DecrRefCount(listPtr);
- listPtr = NULL;
+ sublistCopy = TclListObjCopy(interp, listObj);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
if (sublistCopy == NULL) {
- /*
- * The sublist is not a list at all => error.
- */
-
+ /* The sublist is not a list at all => error. */
break;
}
- TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
+ LIST_ASSERT_TYPE(sublistCopy);
+ ListObjGetElements(sublistCopy, listLen, elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
@@ -1230,26 +2692,24 @@ TclLindexFlat(
*/
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);
return NULL;
}
}
- TclNewObj(listPtr);
+ TclNewObj(listObj);
} else {
- /*
- * Extract the pointer to the appropriate element.
- */
-
- listPtr = elemPtrs[index];
+ /* Extract the pointer to the appropriate element. */
+ listObj = elemPtrs[index];
}
- Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(listObj);
}
Tcl_DecrRefCount(sublistCopy);
}
- return listPtr;
+ return listObj;
}
/*
@@ -1257,31 +2717,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;
/*
@@ -1290,35 +2757,33 @@ 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 */
+ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
- indexListCopy = TclListObjCopy(NULL, indexArgPtr);
+ indexListCopy = TclListObjCopy(NULL, indexArgObj);
if (indexListCopy == NULL) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
+ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
- TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);
+ LIST_ASSERT_TYPE(indexListCopy);
+ ListObjGetElements(indexListCopy, indexCount, indices);
/*
* Let TclLsetFlat perform the actual lset operation.
*/
- retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);
+ retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
Tcl_DecrRefCount(indexListCopy);
- return retValuePtr;
+ return retValueObj;
}
/*
@@ -1327,105 +2792,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;
@@ -1437,21 +2905,27 @@ 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 < 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",
+ NULL);
}
result = TCL_ERROR;
break;
@@ -1459,115 +2933,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;
-
- if (result == TCL_OK) {
- /*
- * We're going to store valuePtr, so spoil string reps of all
- * containing lists.
- */
+ --numPendingInvalidates;
+ objPtr = pendingInvalidatesPtr[numPendingInvalidates];
- 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 = 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;
}
/*
@@ -1575,146 +3063,91 @@ TclLsetFlat(
*
* TclListObjSetElement --
*
- * Set a single element of a list to a specified value.
+ * 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
- *
- * 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 \"%d\" out of range", index));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
+ "OUTOFRANGE", 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;
}
@@ -1724,35 +3157,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;
}
/*
@@ -1760,24 +3192,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);
}
/*
@@ -1785,31 +3218,26 @@ DupListInternalRep(
*
* SetListFromAny --
*
- * Convert any object to a list.
- *
- * Value
+ * Attempt to generate a list internal form for the Tcl object "objPtr".
*
- * TCL_OK
- *
- * Success. The internal representation of 'objPtr' is set, and the type
- * of 'objPtr' is 'tclListType'.
- *
- * 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
@@ -1819,10 +3247,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
@@ -1834,17 +3263,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;
@@ -1853,8 +3287,36 @@ 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;
+ }
+ }
+
} else {
- int estCount, length;
+ Tcl_Size estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
@@ -1865,56 +3327,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 = 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;
}
@@ -1936,53 +3419,57 @@ 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 this is not a spanned list. Marking the
+ * storage canonical for a spanned list make ALL lists using the storage
+ * canonical which is not right. (Consider a list generated from a
+ * string and then this function called for a spanned list generated
+ * from it). On the other hand, a spanned list is always canonical
+ * (never generated from a string) so it does not have to be explicitly
+ * marked as such. The ListObjIsCanonical macro takes this into account.
+ * See the comments there.
*/
+ if (listRep.spanPtr == NULL) {
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */
+ listRep.storePtr->flags |= LISTSTORE_CANONICAL;
+ }
- 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.
- */
-
- flagPtr = ckalloc(numElems);
+ /* 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);
@@ -1994,46 +3481,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 = 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..ee1862d 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,23 +180,23 @@ 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);
code = TCL_ERROR;
@@ -191,7 +204,7 @@ Tcl_LoadObjCmd(
}
/*
- * 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,89 +219,89 @@ 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);
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);
code = TCL_ERROR;
@@ -296,136 +309,139 @@ Tcl_LoadObjCmd(
}
/*
- * 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", 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);
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);
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,19 +621,19 @@ 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);
code = TCL_ERROR;
@@ -614,7 +641,7 @@ Tcl_UnloadObjCmd(
}
/*
- * 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);
code = TCL_ERROR;
goto done;
}
- if (pkgPtr == NULL) {
+ if (libraryPtr == NULL) {
/*
* The DLL pointed by the provided filename has never been loaded.
*/
@@ -700,16 +723,16 @@ Tcl_UnloadObjCmd(
}
/*
- * 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,7 +740,7 @@ 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(
@@ -729,38 +752,89 @@ Tcl_UnloadObjCmd(
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",
+ 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",
+ 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;
}
+
+ /*
+ * Remove this library from the interpreter's library cache.
+ */
+
+ 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 executed fine. Examine the reference count to see
- * if we unload the DLL.
+ * The unload function was called succesfully.
*/
- Tcl_MutexLock(&packageMutex);
+ 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..628deaa 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.
@@ -50,11 +50,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 +64,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.
*/
@@ -266,7 +262,7 @@ Tcl_SourceRCFile(
/*----------------------------------------------------------------------
*
- * Tcl_Main, Tcl_MainEx --
+ * Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -292,6 +288,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 +297,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 +325,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 +348,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 +363,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.
@@ -445,7 +447,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();
@@ -617,21 +619,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 +735,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 +743,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);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 290dcea..2531421 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
@@ -59,7 +60,7 @@ typedef struct ResolvedNsName {
* 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.
@@ -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;
@@ -401,6 +417,8 @@ Tcl_PopCallFrame(
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 +495,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 +527,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;
@@ -551,11 +569,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 +601,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;
@@ -970,20 +988,21 @@ 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) {
@@ -997,16 +1016,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 +1063,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 +1076,83 @@ 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;
+ int i, 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) {
+ int 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) {
+ int 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
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1165,62 +1261,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 +1349,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);
}
}
@@ -1752,9 +1792,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);
@@ -1973,7 +2015,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 +2046,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 +2104,7 @@ DeleteImportedCmd(
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree(refPtr);
+ TclCleanupCommandMacro(realCmdPtr);
ckfree(dataPtr);
return;
}
@@ -2600,7 +2643,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 +2655,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 +2664,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 +2682,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);
@@ -2886,26 +2929,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 +3005,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. */
@@ -3088,7 +3134,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. */
@@ -3169,7 +3215,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 +3278,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,7 +3302,7 @@ 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])));
@@ -3320,7 +3366,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. */
@@ -3452,7 +3498,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 +3553,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 +3635,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 +3700,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 +3815,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 +3912,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 +3925,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);
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 +3972,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,7 +4030,7 @@ 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. */
@@ -4022,7 +4067,7 @@ 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) {
@@ -4211,7 +4256,7 @@ 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. */
@@ -4279,7 +4324,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. */
@@ -4390,7 +4435,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 +4511,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 +4569,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 +4643,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 +4722,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 +4742,6 @@ FreeNsNameInternalRep(
TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree(resNamePtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -4722,11 +4768,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 +4817,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;
}
@@ -4888,8 +4923,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). */
+ int length, /* Number of bytes in command (TCL_INDEX_NONE
+ * 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 */
@@ -4976,7 +5012,7 @@ TclLogCommandInfo(
int 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 +5046,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) {
/*
@@ -5061,7 +5097,7 @@ TclErrorStackResetIf(
int len;
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
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 c8937ef..46ab3b2 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-2012 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}
};
@@ -69,31 +73,28 @@ static void DeletedHelpersNamespace(ClientData 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 Tcl_InterpDeleteProc KillFoundation;
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_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,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
static int PublicNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateObjectCmd(ClientData clientData,
+static int PrivateNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateNRObjectCmd(ClientData clientData,
+static int MyClassNRObjCmd(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(ClientData 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 < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+static inline void
+RemoveObject(
+ Object **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; 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, -1, 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;
@@ -383,28 +368,98 @@ 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.
*/
- fakeCls.thisPtr = &fakeObject;
+ TclNewLiteralStringObj(namePtr, "new");
+ TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
+ fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp,
+ (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
+
+ /*
+ * Create non-object commands and plug ourselves into the Tcl [info]
+ * ensemble.
+ */
+
+ 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;
+ }
- fPtr->objectCls = TclOOAllocClass(interp,
- AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
/*
- * Corresponding TclOODecrRefCount in KillFoudation.
+ * Evaluate the remaining definitions, which are a compiled-in Tcl script.
*/
+ return Tcl_EvalEx(interp, tclOOSetupScript, -1, 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;
+
+ fPtr->objectCls = TclOOAllocClass(interp,
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
+ /* Corresponding TclOODecrRefCount in KillFoudation */
AddRef(fPtr->objectCls->thisPtr);
/*
@@ -423,14 +478,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);
/*
@@ -455,77 +509,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.
+ * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
+ * Everything else is careful to prohibit looping.
*/
-
- 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.
- */
-
- if (TclOODefineSlots(fPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- return Tcl_Eval(interp, slotScript);
}
/*
@@ -543,7 +537,7 @@ static void
DeletedDefineNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->defineNs = NULL;
}
@@ -552,7 +546,7 @@ static void
DeletedObjdefNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->objdefNs = NULL;
}
@@ -561,7 +555,7 @@ static void
DeletedHelpersNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->helpersNs = NULL;
}
@@ -579,10 +573,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);
@@ -620,8 +613,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
@@ -634,7 +627,7 @@ AllocObject(
CommandTrace *tracePtr;
int creationEpoch;
- oPtr = ckalloc(sizeof(Object));
+ oPtr = (Object *)ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -718,8 +711,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;
/*
@@ -734,10 +727,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
@@ -746,7 +738,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;
@@ -754,7 +746,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;
}
@@ -782,12 +777,12 @@ 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.
*
* ----------------------------------------------------------------------
*/
@@ -797,10 +792,18 @@ MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
oPtr->myCommand = NULL;
}
+
+static void
+MyClassDeleted(
+ ClientData clientData)
+{
+ Object *oPtr = (Object *)clientData;
+ oPtr->myclassCommand = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -818,12 +821,13 @@ 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) */
+ 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.
@@ -891,6 +895,7 @@ TclOODeleteDescendants(
ckfree(clsPtr->mixinSubs.list);
clsPtr->mixinSubs.size = 0;
}
+
/*
* Squelch subclasses of this class.
*/
@@ -960,6 +965,7 @@ TclOOReleaseClassContents(
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
+ PrivateVariableMapping *privateVariable;
/*
* Sanity check!
@@ -976,6 +982,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.
*/
@@ -1063,6 +1082,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);
}
@@ -1086,12 +1113,13 @@ ObjectNamespaceDeleted(
ClientData 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;
+ PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
int i;
@@ -1100,6 +1128,7 @@ ObjectNamespaceDeleted(
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
+
return;
}
@@ -1108,6 +1137,7 @@ ObjectNamespaceDeleted(
* process of being deleted, nothing else may modify its bookkeeping
* records. This is the flag that
*/
+
oPtr->flags |= OBJECT_DESTRUCTING;
/*
@@ -1127,7 +1157,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;
@@ -1154,7 +1184,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,
@@ -1168,6 +1198,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);
}
@@ -1212,6 +1245,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);
}
@@ -1244,7 +1285,6 @@ ObjectNamespaceDeleted(
if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
&& !Tcl_InterpDeleted(interp)) {
-
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
@@ -1267,7 +1307,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
@@ -1275,8 +1315,13 @@ ObjectNamespaceDeleted(
*
* ----------------------------------------------------------------------
*/
-int TclOODecrRefCount(Object *oPtr) {
+
+int
+TclOODecrRefCount(
+ Object *oPtr)
+{
if (oPtr->refCount-- <= 1) {
+
if (oPtr->classPtr != NULL) {
ckfree(oPtr->classPtr);
}
@@ -1301,21 +1346,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 --
@@ -1367,9 +1397,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);
}
}
@@ -1466,9 +1496,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);
}
}
@@ -1531,9 +1561,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);
}
}
@@ -1552,6 +1582,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
@@ -1560,7 +1609,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;
@@ -1568,7 +1617,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
@@ -1576,7 +1626,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);
@@ -1594,19 +1644,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);
- }
-}
/*
* ----------------------------------------------------------------------
@@ -1637,7 +1674,9 @@ Tcl_NewObjectInstance(
ClientData 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
@@ -1646,7 +1685,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;
@@ -1706,7 +1745,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
@@ -1717,7 +1758,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;
@@ -1756,8 +1797,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,
@@ -1813,14 +1854,14 @@ FinalizeAlloc(
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)) {
@@ -1886,6 +1927,7 @@ Tcl_CopyObjectInstance(
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+ PrivateVariableMapping *privateVariable;
int i, result;
/*
@@ -1959,7 +2001,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 *);
@@ -1967,6 +2009,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
@@ -2028,11 +2077,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);
@@ -2058,7 +2107,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 *);
@@ -2066,6 +2115,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).
@@ -2142,7 +2198,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;
@@ -2189,7 +2246,7 @@ CloneObjectMethod(
Tcl_Obj *namePtr)
{
if (mPtr->typePtr == NULL) {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2198,10 +2255,10 @@ CloneObjectMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
} else {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
}
return TCL_OK;
@@ -2218,7 +2275,7 @@ CloneClassMethod(
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2227,11 +2284,11 @@ CloneClassMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
@@ -2318,7 +2375,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);
}
@@ -2398,7 +2455,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);
}
@@ -2430,7 +2487,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
@@ -2440,8 +2497,8 @@ Tcl_ObjectSetMetadata(
* ----------------------------------------------------------------------
*/
-static int
-PublicObjectCmd(
+int
+TclOOPublicObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2457,12 +2514,12 @@ PublicNRObjectCmd(
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(
+int
+TclOOPrivateObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2478,7 +2535,7 @@ PrivateNRObjectCmd(
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
+ return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, 0, NULL);
}
int
@@ -2515,6 +2572,43 @@ TclOOInvokeObject(
/*
* ----------------------------------------------------------------------
*
+ * TclOOMyClassObjCmd, MyClassNRObjCmd --
+ *
+ * Special trap door to allow an object to delegate simply to its class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOMyClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
+}
+
+static int
+MyClassNRObjCmd(
+ ClientData 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,
@@ -2539,6 +2633,9 @@ TclOOObjectCmdCore(
{
CallContext *contextPtr;
Tcl_Obj *methodNamePtr;
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+ Object *callerObjPtr = NULL;
+ Class *callerClsPtr = NULL;
int result;
/*
@@ -2553,6 +2650,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.
*/
@@ -2579,7 +2694,8 @@ 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(
@@ -2596,7 +2712,8 @@ 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"
@@ -2647,7 +2764,7 @@ TclOOObjectCmdCore(
static int
FinalizeObjectCall(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
/*
@@ -2655,7 +2772,7 @@ FinalizeObjectCall(
* structure.
*/
- TclOODeleteContext(data[0]);
+ TclOODeleteContext((CallContext *)data[0]);
return result;
}
@@ -2808,10 +2925,10 @@ TclNRObjectContextInvokeNext(
static int
FinalizeNext(
ClientData data[],
- Tcl_Interp *interp,
+ 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
@@ -2846,13 +2963,13 @@ 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(
@@ -3027,6 +3144,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..c933872 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -58,12 +58,12 @@ 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 {
@@ -126,8 +126,28 @@ 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 32 {
+ int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+}
+declare 33 {
+ Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
+}
declare 34 {
- void TclOOUnusedStubEntry(void)
+ Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
}
######################################################################
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 20dc281..775bd32 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,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext objectContext, ptrdiff_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
@@ -77,7 +79,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 +94,41 @@ typedef struct {
* be copied directly. */
} Tcl_MethodType;
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_2 in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc2 *callProc;
+ /* How to invoke this method. */
+ Tcl_MethodDeleteProc *deleteProc;
+ /* How to delete this method's type-specific
+ * data, or NULL if the type-specific data
+ * does not need deleting. */
+ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
+ * data, or NULL if the type-specific data can
+ * be copied directly. */
+} Tcl_MethodType2;
+
/*
* The correct value for the version field of the Tcl_MethodType structure.
* This allows new versions of the structure to be introduced without breaking
* binary compatibility.
*/
+#define TCL_OO_METHOD_VERSION_1 1
+#define TCL_OO_METHOD_VERSION_2 2
#define TCL_OO_METHOD_VERSION_CURRENT 1
+
+/*
+ * Visibility constants for the flags parameter to Tcl_NewMethod and
+ * Tcl_NewInstanceMethod.
+ */
+
+#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..9b72060 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. */
@@ -182,7 +208,7 @@ 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(
@@ -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. */
@@ -247,7 +273,7 @@ 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(
@@ -255,7 +281,7 @@ TclOO_Class_CreateNs(
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
- nsName = Tcl_GetStringFromObj(
+ nsName = TclGetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -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. */
@@ -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);
/*
@@ -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. */
@@ -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);
@@ -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)
@@ -792,7 +886,7 @@ TclOONextObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", 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)
@@ -832,7 +926,7 @@ TclOONextToObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", 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.
@@ -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)
@@ -973,7 +1067,7 @@ TclOOSelfObjCmd(
return TCL_ERROR;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext*)framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
@@ -1054,7 +1148,7 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", 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;
@@ -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..5430a7d 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -4,7 +4,7 @@
* This file contains the method call chain management code for the
* object-system core.
*
- * Copyright (c) 2005-2012 Donal K. Fellows
+ * Copyright © 2005-2012 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 +15,7 @@
#endif
#include "tclInt.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure containing a CallContext and any other values needed only during
@@ -31,6 +32,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.
*/
@@ -46,6 +63,28 @@ struct ChainBuilder {
!((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 +94,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 void AddSimpleClassChainToCallContext(Class *classPtr,
+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 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 +137,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 +247,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 +279,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 +369,18 @@ TclOOInvokeContext(
* Run the method implementation.
*/
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -330,7 +392,7 @@ SetFilterFlags(
static int
ResetFilterFlags(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -342,7 +404,7 @@ ResetFilterFlags(
static int
FinalizeMethodRefs(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -367,6 +429,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 +449,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 +469,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 +483,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 +539,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 +552,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 +690,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 +722,6 @@ AddClassMethodNames(
if (clsPtr->mixins.num != 0) {
Class *mixinPtr;
- int i;
FOREACH(mixinPtr, clsPtr->mixins) {
if (mixinPtr != clsPtr) {
@@ -659,20 +732,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 +742,6 @@ AddClassMethodNames(
}
if (clsPtr->superclasses.num != 0) {
Class *superPtr;
- int i;
FOREACH(superPtr, clsPtr->superclasses) {
AddClassMethodNames(superPtr, flags, namesPtr,
@@ -694,19 +753,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 +881,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 +999,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 +1140,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 +1154,7 @@ TclOOGetCallContext(
CallChain *callPtr;
struct ChainBuilder cb;
int i, count;
- int doFilters;
+ int doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
@@ -1009,15 +1194,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 +1247,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 +1280,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 +1298,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 +1324,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 +1441,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 +1485,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 +1497,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 +1581,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 +1610,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 +1699,7 @@ AddClassFiltersToCallContext(
* ----------------------------------------------------------------------
*/
-static void
+static int
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
@@ -1439,7 +1715,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 +1728,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 +1743,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 +1772,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 +1797,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 +1806,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 +1834,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 +1857,7 @@ TclOORenderCallChain(
Tcl_DecrRefCount(filterLiteral);
Tcl_DecrRefCount(methodLiteral);
Tcl_DecrRefCount(objectLiteral);
+ Tcl_DecrRefCount(privateLiteral);
/*
* Finish building the description and return it.
@@ -1583,6 +1869,246 @@ 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;
+
+ 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, forClass | BUILDING_MIXINS);
+ AddSimpleDefineNamespaces(oPtr, &define, forClass);
+
+ /*
+ * 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 & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
+ 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++;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 647bbd5..13e07ec 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -59,11 +59,11 @@ 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 */
@@ -116,13 +116,27 @@ 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 */
-/* Slot 32 is reserved */
-/* Slot 33 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);
+/* 32 */
+TCLAPI int Tcl_MethodIsType2(Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr);
+/* 33 */
+TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData);
/* 34 */
-TCLAPI void TclOOUnusedStubEntry(void);
+TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType2 *typePtr,
+ void *clientData);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
@@ -143,8 +157,8 @@ 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_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, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
@@ -161,12 +175,12 @@ typedef struct TclOOStubs {
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);
- void (*reserved32)(void);
- void (*reserved33)(void);
- void (*tclOOUnusedStubEntry) (void); /* 34 */
+ int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
+ Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
+ Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
+ int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */
+ Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */
+ Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */
} TclOOStubs;
extern const TclOOStubs *tclOOStubsPtr;
@@ -239,18 +253,21 @@ 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 */
-/* Slot 32 is reserved */
-/* Slot 33 is reserved */
-#define TclOOUnusedStubEntry \
- (tclOOStubsPtr->tclOOUnusedStubEntry) /* 34 */
+#define Tcl_MethodIsPrivate \
+ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
+#define Tcl_GetClassOfObject \
+ (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
+#define Tcl_GetObjectClassName \
+ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
+#define Tcl_MethodIsType2 \
+ (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */
+#define Tcl_NewInstanceMethod2 \
+ (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */
+#define Tcl_NewMethod2 \
+ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */
#endif /* defined(USE_TCLOO_STUBS) */
/* !END!: Do not edit above this line. */
-#undef TclOOUnusedStubEntry
-
#endif /* _TCLOODECLS */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 4b97740..686fd00 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-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.
@@ -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.
@@ -60,6 +69,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[]);
@@ -109,26 +120,59 @@ static int ObjVarsGet(ClientData clientData,
static int ObjVarsSet(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
+static int ResolveClass(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
/*
* 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),
+ {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
@@ -173,6 +217,7 @@ BumpGlobalEpoch(
* ----------------------------------------------------------------------
*
* RecomputeClassCacheFlag --
+ *
* Determine whether the object is prototypical of its class, and hence
* able to use the class's method chain cache.
*
@@ -195,6 +240,7 @@ RecomputeClassCacheFlag(
* ----------------------------------------------------------------------
*
* TclOOObjectSetFilters --
+ *
* Install a list of filter method names into an object.
*
* ----------------------------------------------------------------------
@@ -234,9 +280,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];
@@ -253,6 +299,7 @@ TclOOObjectSetFilters(
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
+ *
* Install a list of filter method names into a class.
*
* ----------------------------------------------------------------------
@@ -292,9 +339,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 +362,7 @@ TclOOClassSetFilters(
* ----------------------------------------------------------------------
*
* TclOOObjectSetMixins --
+ *
* Install a list of mixin classes into an object.
*
* ----------------------------------------------------------------------
@@ -347,10 +395,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;
@@ -374,6 +422,7 @@ TclOOObjectSetMixins(
* ----------------------------------------------------------------------
*
* TclOOClassSetMixins --
+ *
* Install a list of mixin classes into a class.
*
* ----------------------------------------------------------------------
@@ -404,10 +453,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 +476,125 @@ 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.
*
* ----------------------------------------------------------------------
@@ -497,7 +664,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 +684,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 +695,7 @@ RenameDeleteMethod(
int
TclOOUnknownDefinition(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -548,13 +716,13 @@ TclOOUnknownDefinition(
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 +738,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;
@@ -596,6 +764,7 @@ TclOOUnknownDefinition(
* ----------------------------------------------------------------------
*
* FindCommand --
+ *
* Specialized version of Tcl_FindCommand that handles command prefixes
* and disallows namespace magic.
*
@@ -609,7 +778,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 +825,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,8 +845,7 @@ InitDefineContext(
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot process definitions; support namespace deleted",
- -1));
+ "no definition namespace available", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
@@ -698,6 +867,7 @@ InitDefineContext(
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext --
+ *
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
@@ -712,14 +882,15 @@ 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);
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"
@@ -733,11 +904,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 +924,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");
}
@@ -771,11 +944,37 @@ GetClassInOuterContext(
}
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 +999,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 +1013,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 +1065,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 +1080,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 +1092,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,7 +1112,7 @@ 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);
return TCL_ERROR;
@@ -922,7 +1123,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 +1140,7 @@ TclOODefineObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -954,6 +1156,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 +1168,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 +1192,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 +1209,7 @@ TclOOObjDefObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1021,6 +1225,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 +1237,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 +1277,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 +1298,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 +1415,7 @@ TclOODefineSelfObjCmd(
int
TclOODefineClassObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1196,6 +1515,7 @@ TclOODefineClassObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineConstructorObjCmd --
+ *
* Implementation of the "constructor" subcommand of the "oo::define"
* command.
*
@@ -1204,7 +1524,7 @@ TclOODefineClassObjCmd(
int
TclOODefineConstructorObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1230,7 +1550,7 @@ TclOODefineConstructorObjCmd(
}
clsPtr = oPtr->classPtr;
- Tcl_GetStringFromObj(objv[2], &bodyLength);
+ TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1263,7 +1583,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", 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", 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.
*
@@ -1320,6 +1726,7 @@ TclOODefineDeleteMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDestructorObjCmd --
+ *
* Implementation of the "destructor" subcommand of the "oo::define"
* command.
*
@@ -1328,7 +1735,7 @@ TclOODefineDeleteMethodObjCmd(
int
TclOODefineDestructorObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1349,7 +1756,7 @@ TclOODefineDestructorObjCmd(
}
clsPtr = oPtr->classPtr;
- Tcl_GetStringFromObj(objv[1], &bodyLength);
+ TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1384,6 +1791,7 @@ TclOODefineDestructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineExportObjCmd --
+ *
* Implementation of the "export" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1433,7 +1841,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 +1853,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;
}
}
@@ -1478,6 +1887,7 @@ TclOODefineExportObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineForwardObjCmd --
+ *
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1514,6 +1924,9 @@ TclOODefineForwardObjCmd(
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ }
/*
* Create the method structure.
@@ -1538,6 +1951,7 @@ TclOODefineForwardObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
+ *
* Implementation of the "method" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1551,12 +1965,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;
}
@@ -1570,8 +2000,30 @@ TclOODefineMethodObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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 +2031,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 +2047,7 @@ TclOODefineMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineRenameMethodObjCmd --
+ *
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1651,6 +2104,7 @@ TclOODefineRenameMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineUnexportObjCmd --
+ *
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1700,7 +2154,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 +2166,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;
}
}
@@ -1745,6 +2199,7 @@ TclOODefineUnexportObjCmd(
* ----------------------------------------------------------------------
*
* Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *
* How to install a constructor or destructor into a class; API to call
* from C.
*
@@ -1799,6 +2254,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 +2268,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 +2278,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);
@@ -1828,13 +2286,18 @@ TclOODefineSlots(
if (slotObject == NULL) {
continue;
}
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
+ if (slotInfoPtr->resolverType.callProc) {
+ TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ &slotInfoPtr->resolverType, NULL);
+ }
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
+ Tcl_DecrRefCount(resolveName);
return TCL_OK;
}
@@ -1842,6 +2305,7 @@ TclOODefineSlots(
* ----------------------------------------------------------------------
*
* ClassFilterGet, ClassFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
@@ -1850,7 +2314,7 @@ TclOODefineSlots(
static int
ClassFilterGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1884,7 +2348,7 @@ ClassFilterGet(
static int
ClassFilterSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1908,7 +2372,7 @@ ClassFilterSet(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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 +2385,7 @@ ClassFilterSet(
* ----------------------------------------------------------------------
*
* ClassMixinGet, ClassMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
@@ -1929,7 +2394,7 @@ ClassFilterSet(
static int
ClassMixinGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1966,7 +2431,7 @@ ClassMixinGet(
static int
ClassMixinSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1991,12 +2456,12 @@ ClassMixinSet(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2026,6 +2491,7 @@ ClassMixinSet(
* ----------------------------------------------------------------------
*
* ClassSuperGet, ClassSuperSet --
+ *
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
@@ -2034,7 +2500,7 @@ ClassMixinSet(
static int
ClassSuperGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2070,7 +2536,7 @@ ClassSuperGet(
static int
ClassSuperSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2100,7 +2566,7 @@ ClassSuperSet(
"may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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 +2585,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 {
@@ -2176,7 +2642,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 +2658,7 @@ ClassSuperSet(
* ----------------------------------------------------------------------
*
* ClassVarsGet, ClassVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
@@ -2200,14 +2667,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) {
@@ -2225,8 +2692,18 @@ ClassVarsGet(
}
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 +2711,7 @@ ClassVarsGet(
static int
ClassVarsSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2242,7 +2719,7 @@ ClassVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
int i;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
@@ -2259,13 +2736,13 @@ ClassVarsSet(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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(
@@ -2283,49 +2760,11 @@ ClassVarsSet(
}
}
- 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 +2773,7 @@ ClassVarsSet(
* ----------------------------------------------------------------------
*
* ObjectFilterGet, ObjectFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
@@ -2342,7 +2782,7 @@ ClassVarsSet(
static int
ObjFilterGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2370,7 +2810,7 @@ ObjFilterGet(
static int
ObjFilterSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2388,7 +2828,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 +2841,7 @@ ObjFilterSet(
* ----------------------------------------------------------------------
*
* ObjectMixinGet, ObjectMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
@@ -2409,7 +2850,7 @@ ObjFilterSet(
static int
ObjMixinGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2441,7 +2882,7 @@ ObjMixinGet(
static int
ObjMixinSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2461,12 +2902,12 @@ 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);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2486,6 +2927,7 @@ ObjMixinSet(
* ----------------------------------------------------------------------
*
* ObjectVarsGet, ObjectVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
@@ -2494,14 +2936,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 +2955,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 +2974,7 @@ ObjVarsGet(
static int
ObjVarsSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2530,7 +2982,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,13 +2992,13 @@ 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(
@@ -2563,50 +3015,66 @@ ObjVarsSet(
return TCL_ERROR;
}
}
- for (i = 0; i < varc; i++) {
- Tcl_IncrRefCount(varv[i]);
- }
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != varc) {
- if (varc == 0) {
- ckfree((char *) oPtr->variables.list);
- } else if (i) {
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
- } else {
- oPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
- }
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
+ oPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->variables, varc, varv);
}
- oPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
+ 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.
+ *
+ * ----------------------------------------------------------------------
+ */
- Tcl_InitObjHashTable(&uniqueTable);
- for (i = n = 0; i < varc; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
- if (created) {
- oPtr->variables.list[n++] = varv[i];
- } else {
- Tcl_DecrRefCount(varv[i]);
- }
- }
- oPtr->variables.num = n;
+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;
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
+ /*
+ * Check if were called wrongly. The definition context isn't used...
+ * except that GetClassInOuterContext() assumes that it is there.
+ */
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
- Tcl_DeleteHashTable(&uniqueTable);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (objc != idx + 1) {
+ Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
+ return TCL_ERROR;
}
+
+ /*
+ * 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;
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 9f1233c..4e5b55b 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-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.
@@ -22,6 +22,7 @@ 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;
@@ -32,6 +33,7 @@ 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;
@@ -50,6 +52,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 +61,7 @@ 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},
+ {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -71,6 +74,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},
@@ -80,7 +84,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, 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}
};
@@ -167,7 +171,7 @@ GetClassFromObj(
static int
InfoObjectClassCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -202,11 +206,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 +228,7 @@ InfoObjectClassCmd(
static int
InfoObjectDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -257,7 +261,7 @@ InfoObjectDefnCmd(
TclGetString(objv[2]), 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));
@@ -281,7 +285,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 +302,7 @@ InfoObjectDefnCmd(
static int
InfoObjectFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -337,7 +341,7 @@ InfoObjectFiltersCmd(
static int
InfoObjectForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -368,7 +372,7 @@ InfoObjectForwardCmd(
TclGetString(objv[2]), 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",
@@ -394,7 +398,7 @@ InfoObjectForwardCmd(
static int
InfoObjectIsACmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -513,21 +517,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 +567,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",
+ 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 +616,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 +637,7 @@ InfoObjectMethodsCmd(
static int
InfoObjectMethodTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -626,7 +668,7 @@ InfoObjectMethodTypeCmd(
TclGetString(objv[2]), 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 +694,7 @@ InfoObjectMethodTypeCmd(
static int
InfoObjectMixinsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -686,6 +728,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 +769,7 @@ InfoObjectMixinsCmd(
static int
InfoObjectNsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -721,34 +795,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 +856,7 @@ InfoObjectVariablesCmd(
static int
InfoObjectVarsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -827,7 +917,7 @@ InfoObjectVarsCmd(
static int
InfoClassConstrCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -888,7 +978,7 @@ InfoClassConstrCmd(
static int
InfoClassDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -915,7 +1005,7 @@ InfoClassDefnCmd(
TclGetString(objv[2]), 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));
@@ -939,7 +1029,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 +1037,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 +1096,7 @@ InfoClassDefnCmd(
static int
InfoClassDestrCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1000,7 +1140,7 @@ InfoClassDestrCmd(
static int
InfoClassFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1038,7 +1178,7 @@ InfoClassFiltersCmd(
static int
InfoClassForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1063,7 +1203,7 @@ InfoClassForwardCmd(
TclGetString(objv[2]), 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",
@@ -1089,7 +1229,7 @@ InfoClassForwardCmd(
static int
InfoClassInstancesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1130,27 +1270,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 +1325,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",
+ 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 +1372,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 +1393,7 @@ InfoClassMethodsCmd(
static int
InfoClassMethodTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1247,7 +1420,7 @@ InfoClassMethodTypeCmd(
TclGetString(objv[2]), 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 +1445,7 @@ InfoClassMethodTypeCmd(
static int
InfoClassMixinsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1314,7 +1487,7 @@ InfoClassMixinsCmd(
static int
InfoClassSubsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1369,7 +1542,7 @@ InfoClassSubsCmd(
static int
InfoClassSupersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1401,34 +1574,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 +1635,7 @@ InfoClassVariablesCmd(
static int
InfoObjectCallCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1467,7 +1656,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 +1681,7 @@ InfoObjectCallCmd(
static int
InfoClassCallCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 2931044..bbe4102 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -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
@@ -142,6 +154,13 @@ typedef struct ForwardMethod {
struct { int num, size; listType_t *list; }
/*
+ * These types are needed in function arguments.
+ */
+
+typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
+typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
+
+/*
* Now, the definition of what an object actually is.
*/
@@ -186,7 +205,12 @@ 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. */
} Object;
#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
@@ -211,7 +235,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
@@ -266,7 +297,28 @@ 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. */
} Class;
/*
@@ -372,6 +424,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 +447,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
@@ -484,6 +492,17 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
+MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr);
+MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType *typePtr,
+ void *clientData);
+MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType *typePtr,
+ void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, int objc,
@@ -504,7 +523,10 @@ MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
MODULE_SCOPE void TclOODelMethodRef(Method *method);
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 +535,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);
@@ -564,21 +587,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: int 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/tclOOMethod.c b/generic/tclOOMethod.c
index edaa593..2386c15 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)))
/*
* ----------------------------------------------------------------------
@@ -134,8 +126,8 @@ static const Tcl_MethodType fwdMethodType = {
*/
Tcl_Method
-Tcl_NewInstanceMethod(
- Tcl_Interp *interp, /* Unused? */
+TclNewInstanceMethod(
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
@@ -186,11 +178,59 @@ 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;
}
+Tcl_Method
+Tcl_NewInstanceMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
+Tcl_Method
+Tcl_NewInstanceMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -203,8 +243,8 @@ Tcl_NewInstanceMethod(
*/
Tcl_Method
-Tcl_NewMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
+TclNewMethod(
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
@@ -250,11 +290,57 @@ 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;
}
+
+Tcl_Method
+Tcl_NewMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData);
+}
+
+Tcl_Method
+Tcl_NewMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -304,7 +390,7 @@ TclOONewBasicMethod(
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
Tcl_IncrRefCount(namePtr);
- Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
Tcl_DecrRefCount(namePtr);
}
@@ -339,7 +425,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 +483,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));
@@ -529,7 +615,7 @@ TclOOMakeProcInstanceMethod(
}
}
- return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
+ return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
}
@@ -642,7 +728,7 @@ TclOOMakeProcMethod(
}
}
- return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
+ return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
clientData);
}
@@ -793,6 +879,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 +945,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 +1015,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 +1038,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 +1071,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 +1105,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 +1123,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 +1185,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 +1256,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 +1265,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 +1286,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 +1297,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 +1317,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 +1327,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 +1347,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 +1424,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,7 +1475,7 @@ TclOONewForwardInstanceMethod(
int prefixLen;
ForwardMethod *fmPtr;
- if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
@@ -1383,7 +1488,7 @@ TclOONewForwardInstanceMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
+ return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
@@ -1409,7 +1514,7 @@ TclOONewForwardMethod(
int prefixLen;
ForwardMethod *fmPtr;
- if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
@@ -1422,7 +1527,7 @@ TclOONewForwardMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
@@ -1457,7 +1562,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 +1610,7 @@ DeleteForwardMethod(
static int
CloneForwardMethod(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
void *clientData,
void **newClientData)
{
@@ -1548,9 +1653,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;
@@ -1655,6 +1758,23 @@ Tcl_MethodName(
}
int
+TclMethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
@@ -1662,6 +1782,9 @@ Tcl_MethodIsType(
{
Method *mPtr = (Method *) method;
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType");
+ }
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
@@ -1672,11 +1795,38 @@ Tcl_MethodIsType(
}
int
+Tcl_MethodIsType2(
+ Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2");
+ }
+ if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsPublic(
Tcl_Method method)
{
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..f2e99b0
--- /dev/null
+++ b/generic/tclOOScript.h
@@ -0,0 +1,263 @@
+/*
+ * 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 generic/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\t::namespace 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 -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class ::oo::objdefine::mixin -append $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 {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Resolve list {\n"
+"\t\t\treturn $list\n"
+"\t\t}\n"
+"\t\tmethod -set 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 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 -clear {} {tailcall my Set {}}\n"
+"\t\tmethod -prepend 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 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 {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\texport -set -append -clear -prepend -remove\n"
+"\t\tunexport unknown 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> {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> {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> {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"
+"}\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..7b653cb 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -14,8 +14,6 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#pragma GCC dependency "tclOO.decls"
#endif
-#define TclOOUnusedStubEntry 0
-
/* !BEGIN!: Do not edit below this line. */
static const TclOOIntStubs tclOOIntStubs = {
@@ -75,12 +73,12 @@ const TclOOStubs tclOOStubs = {
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
- 0, /* 29 */
- 0, /* 30 */
- 0, /* 31 */
- 0, /* 32 */
- 0, /* 33 */
- TclOOUnusedStubEntry, /* 34 */
+ Tcl_MethodIsPrivate, /* 29 */
+ Tcl_GetClassOfObject, /* 30 */
+ Tcl_GetObjectClassName, /* 31 */
+ Tcl_MethodIsType2, /* 32 */
+ Tcl_NewInstanceMethod2, /* 33 */
+ Tcl_NewMethod2, /* 34 */
};
/* !END!: Do not edit above this line. */
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..933138c 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,9 +50,8 @@ 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,
@@ -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,7 +336,7 @@ 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
@@ -361,7 +352,7 @@ typedef struct ResolvedCmdName {
* 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,28 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
- Tcl_RegisterObjType(&tclEndOffsetType);
- Tcl_RegisterObjType(&tclIntType);
+#if (TCL_UTF_MAX < 4) || !defined(TCL_NO_DEPRECATED)
Tcl_RegisterObjType(&tclStringType);
+#endif
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+ /* 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 +446,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 +455,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);
@@ -576,7 +574,7 @@ TclContinuationsEnter(
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) {
/*
@@ -733,7 +731,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 +767,7 @@ TclContinuationsGet(
if (!hPtr) {
return NULL;
}
- return Tcl_GetHashValue(hPtr);
+ return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
@@ -792,7 +790,7 @@ TclContinuationsGet(
static void
TclThreadFinalizeContLines(
- ClientData clientData)
+ TCL_UNUSED(void *))
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -884,7 +882,7 @@ Tcl_AppendAllObjTypes(
* 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 +895,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 +928,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;
@@ -1001,11 +999,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;
@@ -1017,7 +1015,7 @@ TclDbDumpActiveObjects(
fprintf(outFile, "total objects: %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 +1028,14 @@ TclDbDumpActiveObjects(
}
}
}
-#endif
}
+#else
+void
+TclDbDumpActiveObjects(
+ TCL_UNUSED(FILE *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -1061,11 +1065,10 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
objPtr->typePtr = NULL;
+ TclInitStringRep(objPtr, NULL, 0);
-#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,10 +1205,8 @@ 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();
}
@@ -1301,7 +1302,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 +1324,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);
@@ -1379,7 +1380,7 @@ TclFreeObj(
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
- TclFreeIntRep(objToFree);
+ TclFreeInternalRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
ckfree(objToFree);
@@ -1598,7 +1599,7 @@ TclSetDuplicateObj(
Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
}
TclInvalidateStringRep(dupPtr);
- TclFreeIntRep(dupPtr);
+ TclFreeInternalRep(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
}
@@ -1623,37 +1624,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;
}
@@ -1661,7 +1661,7 @@ Tcl_GetString(
/*
*----------------------------------------------------------------------
*
- * Tcl_GetStringFromObj --
+ * Tcl_GetStringFromObj/TclGetStringFromObj --
*
* Returns the string representation's byte array pointer and length for
* an object.
@@ -1681,6 +1681,7 @@ Tcl_GetString(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetStringFromObj
char *
Tcl_GetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
@@ -1689,13 +1690,178 @@ 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;
}
return objPtr->bytes;
}
+
+#undef TclGetStringFromObj
+char *
+TclGetStringFromObj(
+ Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
+ * be returned. */
+ void *lengthPtr) /* If non-NULL, the location where the string
+ * rep's byte array length should * be stored.
+ * If NULL, no length is stored. */
+{
+ 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) {
+ *(ptrdiff_t *)lengthPtr = ((ptrdiff_t)(unsigned)(objPtr->length + 1)) - 1;
+ }
+ return objPtr->bytes;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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) {
+ TclInitStringRep(objPtr, NULL, 0);
+ 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);
+ TclInitStringRep(objPtr, NULL, 0);
+ 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;
+}
/*
*----------------------------------------------------------------------
@@ -1726,6 +1892,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 --
+ *
+ * This function is 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 +2011,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 +2030,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 +2041,7 @@ Tcl_NewBooleanObj(
{
Tcl_Obj *objPtr;
- TclNewBooleanObj(objPtr, intValue);
+ TclNewIntObj(objPtr, intValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1795,6 +2072,7 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
@@ -1809,9 +2087,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 +2100,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 +2135,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 +2158,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, -1, 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 +2203,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 +2257,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 +2280,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 +2290,6 @@ TclSetBooleanFromAny(
goto badBoolean;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- goto badBoolean;
- }
-#endif
-
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
@@ -1989,7 +2302,7 @@ TclSetBooleanFromAny(
badBoolean:
if (interp != NULL) {
int length;
- const char *str = TclGetStringFromObj(objPtr, &length);
+ const char *str = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
@@ -2005,9 +2318,10 @@ 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);
+ const char *str = TclGetString(objPtr);
+ size_t i, length = objPtr->length;
if ((length == 0) || (length > 5)) {
/*
@@ -2105,14 +2419,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 +2515,7 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
@@ -2213,10 +2528,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,7 +2593,7 @@ 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));
@@ -2293,22 +2606,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 +2674,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 +2712,7 @@ UpdateStringOfDouble(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewIntObj
#ifdef TCL_MEM_DEBUG
@@ -2415,7 +2720,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 +2735,7 @@ Tcl_NewIntObj(
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2448,7 +2754,7 @@ Tcl_NewIntObj(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
@@ -2461,32 +2767,30 @@ Tcl_SetIntObj(
TclSetIntObj(objPtr, intValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
- * Retrieve the integer value of 'objPtr'.
- *
- * Value
- *
- * TCL_OK
+ * 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.
*
- * 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,20 +2804,12 @@ 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";
@@ -2522,10 +2818,11 @@ Tcl_GetIntFromObj(
}
return TCL_ERROR;
}
- *intPtr = (int)*(long *)p;
+ *intPtr = (int) l;
return TCL_OK;
#endif
}
+
/*
*----------------------------------------------------------------------
@@ -2548,9 +2845,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 +2872,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);
+
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.wideValue));
+}
- len = TclFormatInt(buffer, objPtr->internalRep.longValue);
+#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 +2922,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 +2943,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 +2981,8 @@ Tcl_NewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_DbNewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
@@ -2687,9 +2997,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 +3011,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 +3037,8 @@ Tcl_DbNewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -2737,8 +3049,9 @@ Tcl_SetLongObj(
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
- TclSetLongObj(objPtr, longValue);
+ TclSetIntObj(objPtr, longValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2768,14 +3081,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 +3098,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;
@@ -2809,28 +3123,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
@@ -2847,49 +3163,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 +3212,7 @@ Tcl_NewWideIntObj(
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2991,7 +3264,7 @@ Tcl_DbNewWideIntObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
@@ -3002,10 +3275,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 +3311,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 +3343,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) {
@@ -3104,25 +3363,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) {
@@ -3138,33 +3398,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", 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, 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", 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 +3572,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 +3605,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 +3638,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 +3656,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 +3686,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 +3724,7 @@ Tcl_NewBignumObj(
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBignumObj(
- mp_int *bignumValue,
+ void *bignumValue,
const char *file,
int line)
{
@@ -3352,9 +3737,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,37 +3778,34 @@ 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);
+ TclInitStringRep(objPtr, NULL, 0);
}
}
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(
@@ -3467,9 +3849,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 +3884,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 +3909,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 +3963,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 +3984,7 @@ TclSetBignumInternalRep(
/*
*----------------------------------------------------------------------
*
- * TclGetNumberFromObj --
+ * Tcl_GetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
@@ -3648,15 +4002,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 +4019,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 +4037,107 @@ TclGetNumberFromObj(
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
return TCL_ERROR;
}
+
+int
+Tcl_GetNumber(
+ Tcl_Interp *interp,
+ const char *bytes,
+ ptrdiff_t 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 = (ptrdiff_t)strlen(bytes);
+ }
+ if (numBytes > INT_MAX) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ 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:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#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 +4160,7 @@ TclGetNumberFromObj(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
@@ -3721,14 +4170,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 +4198,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 +4233,7 @@ Tcl_DbIncrRefCount(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
@@ -3784,14 +4243,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 +4271,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 +4314,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 +4331,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 +4416,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,7 +4451,7 @@ TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- Tcl_Obj *objPtr1 = keyPtr;
+ Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
const char *p1, *p2;
size_t l1, l2;
@@ -4060,15 +4535,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;
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
- unsigned int result = 0;
+ 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 +4638,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 +4662,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 +4690,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;
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ fillPtr->refNsPtr = currNsPtr;
+ fillPtr->refNsId = currNsPtr->nsId;
+ fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
+
+ if (resPtr == NULL) {
+ TclFreeInternalRep(objPtr);
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
}
+}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+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;
+
+ if (objPtr->typePtr == &tclCmdNameType) {
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
+ }
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
/*
@@ -4295,15 +4790,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 +4809,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
- }
objPtr->typePtr = NULL;
}
@@ -4344,13 +4837,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 +4871,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 +4892,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 +4938,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 +4956,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);
+ " 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..5ee1a9f 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 = TclUtfToUCS4(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[8];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
- count = TclUtfToUCS4(utfBytes, &result) + 1;
+ count = TclUtfToUCS4(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..ce9db2a 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.
@@ -36,7 +36,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp,
* internally.
*/
-static const Tcl_ObjType tclFsPathType = {
+static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
@@ -47,46 +47,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 +85,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 +115,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.
*
*---------------------------------------------------------------------------
*/
@@ -232,7 +212,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,7 +238,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);
}
@@ -289,7 +269,7 @@ TclFSNormalizeAbsolutePath(
*/
const char *path =
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
while (--curLen >= 0) {
if (IsSeparatorOrNull(path[curLen])) {
@@ -304,7 +284,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 +297,7 @@ TclFSNormalizeAbsolutePath(
} else {
retVal = linkObj;
}
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
@@ -334,7 +314,7 @@ TclFSNormalizeAbsolutePath(
}
}
} else {
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
@@ -405,7 +385,7 @@ TclFSNormalizeAbsolutePath(
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
int len;
- const char *path = Tcl_GetStringFromObj(retVal, &len);
+ const char *path = TclGetStringFromObj(retVal, &len);
if (len == 2 && path[0] != 0 && path[1] == ':') {
if (Tcl_IsShared(retVal)) {
@@ -564,7 +544,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 +560,7 @@ TclPathPart(
int numBytes;
const char *rest =
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -618,7 +598,7 @@ TclPathPart(
int numBytes;
const char *rest =
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -647,7 +627,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 +679,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 +694,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 +812,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 +844,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 +855,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 +871,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 +942,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 +1038,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 +1072,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 +1084,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 +1150,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 +1274,7 @@ TclNewFSPathObj(
}
TclNewObj(pathPtr);
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* Set up the path.
@@ -1336,9 +1291,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 +1353,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 +1386,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 +1413,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 +1433,7 @@ TclFSMakePathRelative(
}
break;
}
- tempStr = Tcl_GetStringFromObj(pathPtr, &len);
+ tempStr = TclGetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
@@ -1503,36 +1457,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 +1474,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 +1483,6 @@ MakePathFromNormalized(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -1563,7 +1492,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 +1533,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 +1546,6 @@ Tcl_FSNewNativePath(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return pathPtr;
}
@@ -1640,16 +1555,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 +1584,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 +1599,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 +1659,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 +1716,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 +1731,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 +1768,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 +1783,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
} else {
@@ -1881,10 +1791,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
@@ -1896,10 +1802,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 +1814,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 +1829,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 +1878,6 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
- pureNormalized = 0;
Tcl_DecrRefCount(absolutePath);
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
@@ -1995,7 +1897,6 @@ Tcl_FSGetNormalizedPath(
if (absolutePath == NULL) {
return NULL;
}
- pureNormalized = 0;
#endif /* _WIN32 */
}
}
@@ -2004,35 +1905,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 +1931,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 +1965,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 +2015,7 @@ Tcl_FSGetInternalRep(
return NULL;
}
- nativePathPtr = proc(pathPtr);
+ nativePathPtr = (char *)proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
@@ -2160,15 +2029,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 +2049,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 +2107,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 +2181,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 +2205,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 +2225,7 @@ SetFsPathFromAny(
* cmdAH.test exercise most of the code).
*/
- name = Tcl_GetStringFromObj(pathPtr, &len);
+ name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
@@ -2406,7 +2270,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&dirString);
} else {
/*
- * We have a user name '~user'
+ * There is a '~user'
*/
const char *expandedUser;
@@ -2431,7 +2295,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&userName);
}
- transPtr = TclDStringToObj(&temp);
+ transPtr = Tcl_DStringToObj(&temp);
if (split != len) {
/*
@@ -2449,7 +2313,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 +2347,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 +2388,7 @@ FreeFsPathInternalRep(
}
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
}
if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
@@ -2540,7 +2401,6 @@ FreeFsPathInternalRep(
}
ckfree(fsPathPtr);
- pathPtr->typePtr = NULL;
}
static void
@@ -2549,28 +2409,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 +2446,6 @@ DupFsPathInternalRep(
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
-
- copyPtr->typePtr = &tclFsPathType;
}
/*
@@ -2629,11 +2477,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;
+ TclInitStringRep(copy, NULL, 0);
TclDecrRefCount(copy);
}
@@ -2661,7 +2513,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 +2522,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 +2537,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 +2561,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", NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ /* User name specified - ~user */
+ dir = TclpGetUserHome(user, &dirString);
+ if (dir == NULL) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", user));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
+ NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
+ if (subPath) {
+ const char *parts[2];
+ parts[0] = dir;
+ parts[1] = subPath;
+ Tcl_JoinPath(2, parts, dsPtr);
+ } else {
+ Tcl_JoinPath(1, &dir, dsPtr);
+ }
+
+ Tcl_DStringFree(&dirString);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetHomeDirObj --
+ *
+ * Wrapper around MakeTildeRelativePath. See that function.
+ *
+ * Results:
+ * Returns a Tcl_Obj containing the home directory of a user
+ * or NULL on failure with error message in interp if non-NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclGetHomeDirObj(
+ Tcl_Interp *interp, /* May be NULL. Only used for error messages */
+ const char *user) /* User name. NULL -> current user */
+{
+ Tcl_DString dirString;
+
+ if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) {
+ return NULL;
+ }
+ return 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..830f3f6 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.
@@ -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) {
@@ -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
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index ec932f1..c5b2d38 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)
@@ -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,18 +381,11 @@ 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));
@@ -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,79 +445,117 @@ 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));
@@ -445,20 +568,31 @@ 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));
@@ -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;
@@ -534,10 +675,10 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
}
/*
- * 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);
@@ -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
@@ -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);
}
@@ -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')) ||
@@ -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);
@@ -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..659c3e6 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,7 +67,7 @@ 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 */
@@ -70,10 +78,10 @@ EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
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_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..3abf3c3 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,8 +34,7 @@ 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, int skip);
static void InitResolvedLocals(Tcl_Interp *interp,
ByteCode *codePtr, Var *defPtr,
Namespace *nsPtr);
@@ -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;
@@ -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);
@@ -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;
}
@@ -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;
@@ -496,7 +530,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", 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",
@@ -504,15 +538,17 @@ TclCreateProc(
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])));
@@ -520,7 +556,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", 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]);
@@ -530,7 +566,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei++;
}
if (precompiled) {
@@ -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
@@ -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,11 +836,11 @@ 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);
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. */
@@ -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,
* 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_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,7 +1667,7 @@ 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. */
@@ -1668,6 +1683,43 @@ TclNRInterpProc(
}
return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
+
+static int
+NRInterpProc2(
+ void *clientData, /* Record describing procedure to be
+ * interpreted. */
+ Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ ptrdiff_t objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ int result = TclPushProcCallFrame(clientData, interp, objc, objv,
+ /*isLambda*/ 0);
+
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+}
+
+static int
+ObjInterpProc2(
+ void *clientData, /* Record describing procedure to be
+ * interpreted. */
+ Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ ptrdiff_t objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ /*
+ * Not used much in the core; external interface for iTcl
+ */
+
+ return Tcl_NRCallObjProc2(interp, NRInterpProc2, clientData, objc, objv);
+}
+
/*
*----------------------------------------------------------------------
@@ -1692,7 +1744,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 +1755,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 +1768,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 +1786,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 +1807,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 +1815,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 +1829,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1786,7 +1838,7 @@ TclNRInterpProcCore(
static int
InterpProcNR2(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1797,7 +1849,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 +1872,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 ?
@@ -1909,7 +1961,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 +1980,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)
@@ -1947,11 +2001,12 @@ TclProcCompileProc(
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
@@ -1970,6 +2025,9 @@ TclProcCompileProc(
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
+#else
+ (void)description;
+ (void)procName;
#endif
/*
@@ -2072,13 +2130,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 +2163,7 @@ MakeProcError(
void
TclProcDeleteProc(
- ClientData clientData) /* Procedure to be deleted. */
+ void *clientData) /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *)clientData;
@@ -2144,11 +2203,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);
}
@@ -2253,15 +2312,16 @@ TclUpdateReturnInfo(
/*
*----------------------------------------------------------------------
*
- * TclGetObjInterpProc --
+ * TclGetObjInterpProc/TclGetObjInterpProc2 --
*
- * 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/ObjInterpProc2 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/ObjInterpProc2
+ * functions.
*
* Side effects:
* None.
@@ -2274,6 +2334,12 @@ TclGetObjInterpProc(void)
{
return TclObjInterpProc;
}
+
+Tcl_ObjCmdProc2 *
+TclGetObjInterpProc2(void)
+{
+ return ObjInterpProc2;
+}
/*
*----------------------------------------------------------------------
@@ -2307,10 +2373,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
- objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
-
- procPtr->refCount++;
+ ProcSetInternalRep(objPtr, procPtr);
}
return objPtr;
@@ -2338,11 +2401,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 +2430,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 +2458,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 +2474,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;
- if (procPtr->refCount-- == 1) {
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
+
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
- objPtr->typePtr = NULL;
}
static int
@@ -2428,7 +2494,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,10 +2505,18 @@ 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);
+ 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",
@@ -2579,21 +2654,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 +2710,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 +2720,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 +2742,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 +2789,7 @@ TclNRApplyObjCmd(
static int
ApplyNR2(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2736,13 +2824,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..aec8c0a
--- /dev/null
+++ b/generic/tclProcess.c
@@ -0,0 +1,950 @@
+/*
+ * 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. */
+ int 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,
+ int resolvedPid);
+static void FreeProcessInfo(ProcessInfo *info);
+static int RefreshProcessInfo(ProcessInfo *info, int options);
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int 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. */
+ int 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. */
+ int 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.
+ */
+
+ return Tcl_NewObj();
+ }
+ 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;
+ 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);
+ Tcl_ListObjAppendElement(interp, list,
+ Tcl_NewWideIntObj(info->resolvedPid));
+ }
+ 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;
+ int index, options = WNOHANG;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+ int numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int i;
+ 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.
+ */
+
+ Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid),
+ 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.
+ */
+
+ Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid),
+ 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;
+ int numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int i;
+ 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. */
+{
+ int 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..8e0681c 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.
@@ -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..7e108e9 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.
@@ -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;
@@ -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.
*/
@@ -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.
*/
@@ -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,7 +1682,7 @@ 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)));
diff --git a/generic/tclScan.c b/generic/tclScan.c
index ba3d90f..f332d24 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
@@ -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
@@ -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,
@@ -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", 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",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", 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
{
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 75125f0..664a18c 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,9 @@ TclParseNumber(
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
int explicitOctal = 0;
+ mp_err err = MP_OKAY;
+ int under = 0; /* Flag trailing '_' as error if true once
+ * number is accepted. */
#define MOST_BITS (UWIDE_MAX >> 1)
@@ -550,6 +551,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);
}
@@ -634,7 +649,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
- if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY)) {
+ if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY) || under) {
goto endgame;
}
state = ZERO_X;
@@ -647,7 +662,7 @@ TclParseNumber(
goto zeroo;
}
if (c == 'b' || c == 'B') {
- if (flags & TCL_PARSE_OCTAL_ONLY) {
+ if ((flags & TCL_PARSE_OCTAL_ONLY) || under) {
goto endgame;
}
state = ZERO_B;
@@ -657,11 +672,21 @@ TclParseNumber(
goto zerob;
}
if (c == 'o' || c == 'O') {
+ if (under) {
+ goto endgame;
+ }
explicitOctal = 1;
state = ZERO_O;
break;
}
-#ifdef KILL_OCTAL
+ if (c == 'd' || c == 'D') {
+ if (under) {
+ goto endgame;
+ }
+ state = ZERO_D;
+ break;
+ }
+#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
@@ -681,9 +706,11 @@ TclParseNumber(
zeroo:
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = OCTAL;
break;
} else if (c >= '1' && c <= '7') {
+ under = 0;
if (objPtr != NULL) {
shift = 3 * (numTrailZeros + 1);
significandOverflow = AccumulateDecimalDigit(
@@ -704,7 +731,7 @@ TclParseNumber(
|| (octalSignificandWide >
(UWIDE_MAX >> shift)))) {
octalSignificandOverflow = 1;
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
}
@@ -721,10 +748,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) {
@@ -735,6 +769,10 @@ TclParseNumber(
numTrailZeros = 0;
state = OCTAL;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
/* FALLTHROUGH */
@@ -753,7 +791,7 @@ TclParseNumber(
goto endgame;
}
-#ifndef KILL_OCTAL
+#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
@@ -763,6 +801,7 @@ TclParseNumber(
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = BAD_OCTAL;
break;
} else if (isdigit(UCHAR(c))) {
@@ -778,12 +817,15 @@ TclParseNumber(
numSigDigs = 1;
}
numTrailZeros = 0;
+ under = 0;
state = BAD_OCTAL;
break;
} else if (c == '.') {
+ under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
+ under = 0;
state = EXPONENT_START;
break;
}
@@ -806,14 +848,22 @@ TclParseNumber(
zerox:
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
+ under = 0;
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
+ under = 0;
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
+ under = 0;
d = (c-'a'+10);
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
} else {
goto endgame;
}
@@ -830,7 +880,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 +896,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;
@@ -864,10 +919,17 @@ TclParseNumber(
zerob:
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = BINARY;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
} else if (c != '1') {
goto endgame;
+ } else {
+ under = 0;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
@@ -882,7 +944,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 +960,44 @@ 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') {
+ under = 0;
+ numTrailZeros++;
+ } else if ( ! isdigit(UCHAR(c))) {
+ if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
+ }
+ goto endgame;
+ }
+ under = 0;
+ 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;
@@ -921,6 +1005,7 @@ TclParseNumber(
acceptLen = len;
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
@@ -932,14 +1017,21 @@ TclParseNumber(
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
+ under = 0;
state = DECIMAL;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
+ under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
+ under = 0;
state = EXPONENT_START;
break;
}
@@ -965,6 +1057,7 @@ TclParseNumber(
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
+ under = 0;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
@@ -981,8 +1074,13 @@ TclParseNumber(
numSigDigs = 1;
}
numTrailZeros = 0;
+ under = 0;
state = FRACTION;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
goto endgame;
@@ -994,10 +1092,12 @@ TclParseNumber(
*/
if (c == '+') {
+ under = 0;
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
+ under = 0;
state = EXPONENT_SIGNUM;
break;
}
@@ -1011,8 +1111,13 @@ TclParseNumber(
if (isdigit(UCHAR(c))) {
exponent = c - '0';
+ under = 0;
state = EXPONENT;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
goto endgame;
@@ -1031,8 +1136,13 @@ TclParseNumber(
} else {
exponent = LONG_MAX;
}
+ under = 0;
state = EXPONENT;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
goto endgame;
@@ -1043,12 +1153,14 @@ TclParseNumber(
case sI:
if (c == 'n' || c == 'N') {
+ under = 0;
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
+ under = 0;
state = sINF;
break;
}
@@ -1057,6 +1169,7 @@ TclParseNumber(
acceptState = state;
acceptPoint = p;
acceptLen = len;
+ under = 0;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
@@ -1064,24 +1177,28 @@ TclParseNumber(
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
+ under = 0;
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
+ under = 0;
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
+ under = 0;
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
+ under = 0;
state = sINFINITY;
break;
}
@@ -1093,12 +1210,14 @@ TclParseNumber(
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
+ under = 0;
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
+ under = 0;
state = sNAN;
break;
}
@@ -1108,6 +1227,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == '(') {
+ under = 0;
state = sNANPAREN;
break;
}
@@ -1118,12 +1238,14 @@ TclParseNumber(
*/
case sNANHEX:
if (c == ')') {
+ under = 0;
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
if (TclIsSpaceProcM(c)) {
+ under = 0;
break;
}
if (numSigDigs < 13) {
@@ -1138,6 +1260,7 @@ TclParseNumber(
}
numSigDigs++;
significandWide = (significandWide << 4) + d;
+ under = 0;
state = sNANHEX;
break;
}
@@ -1168,10 +1291,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;
+ p = under ? acceptPoint-1 : acceptPoint;
+ len = under ? acceptLen-1 : acceptLen;
+
if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
/*
* Accept trailing whitespace.
@@ -1196,13 +1322,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 +1353,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 +1366,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 +1385,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 +1398,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 +1417,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 +1431,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:
@@ -1550,7 +1661,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 +1683,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 +1699,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 +1822,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 +1874,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 +2050,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 +2099,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 +2111,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 +2123,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 +2153,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 +2207,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 +2221,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 +2268,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 +2277,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 +2495,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 +2532,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 +2713,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 +2724,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 +2740,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 +3027,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 +3078,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 +3098,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 +3173,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 +3189,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 +3239,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 +3268,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 +3339,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 +3352,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 +3483,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 +3494,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 +3507,6 @@ ShouldBankerRoundUpToNextPowD(
return 1;
}
}
- if (convType == TCL_DD_STEELE0) {
- /* Biased rounding. */
- return 0;
- }
return isodd;
}
@@ -3407,8 +3536,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 +3552,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 +3562,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 +3597,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 +3637,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 +3665,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 +3693,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;
}
@@ -3572,7 +3719,7 @@ ShorteningBignumConversionPowD(
if (endPtr) {
*endPtr = s;
}
- return retval;
+ return (err == MP_OKAY) ? retval : NULL;
}
/*
@@ -3599,9 +3746,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 +3759,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 +3796,7 @@ StrictBignumConversionPowD(
*/
i = 1;
- for (;;) {
+ while (err == MP_OKAY) {
if (b.used <= sd) {
digit = 0;
} else {
@@ -3681,7 +3828,7 @@ StrictBignumConversionPowD(
* Advance to the next digit.
*/
- mp_mul_d(&b, 10, &b);
+ err = mp_mul_d(&b, 10, &b);
++i;
}
@@ -3690,7 +3837,7 @@ StrictBignumConversionPowD(
* string.
*/
- mp_clear_multi(&b, &temp, NULL);
+ mp_clear(&b);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -3723,15 +3870,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 +3899,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 +3944,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 +3955,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 +3964,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 +4003,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 +4037,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 +4056,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 +4073,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 +4085,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 +4129,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 +4150,7 @@ ShorteningBignumConversion(
if (m2plus > m2minus) {
mp_clear(&mplus);
}
- mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL);
+ mp_clear_multi(&b, &mminus, &dig, &S, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4020,8 +4179,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 +4189,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 +4237,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 +4249,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 +4263,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 +4290,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 +4308,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 +4325,7 @@ StrictBignumConversion(
* string.
*/
- mp_clear_multi(&b, &S, &temp, &dig, NULL);
+ mp_clear_multi(&b, &S, &dig, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4191,22 +4361,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 +4378,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 +4411,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 +4478,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 +4515,7 @@ TclDoubleDigits(
* denominator.
*/
- if (flags & TCL_DD_SHORTEN_FLAG) {
+ if (flags & TCL_DD_SHORTEST) {
int m2minus = b2;
int m2plus;
int m5 = b5;
@@ -4405,7 +4562,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 +4581,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 +4590,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 +4618,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 +4635,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 +4645,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 +4683,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 +4740,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,16 +4840,18 @@ 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";
@@ -4698,21 +4861,26 @@ Tcl_InitBignumFromDouble(
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 +4901,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 +4936,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 +4951,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 +4965,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 +4981,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 +5023,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 +5042,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 +5089,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 +5109,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 +5158,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 +5167,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 +5183,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 +5234,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 +5325,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 b1046b1..0e47487 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,35 +43,63 @@
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 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 (TCL_UTF_MAX) > 3 && !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))))
+
/*
* The structure below defines the string Tcl object type by means of
* functions that can be invoked by generic object code.
*/
+#if TCL_UTF_MAX < 4
+
+#define tclUniCharStringType tclStringType
+#define GET_UNICHAR_STRING GET_STRING
+#define UniCharString String
+#define UNICHAR_STRING_MAXCHARS STRING_MAXCHARS
+#define uniCharStringAlloc stringAlloc
+#define uniCharStringRealloc stringRealloc
+#define uniCharStringAttemptAlloc stringAttemptAlloc
+#define uniCharStringAttemptRealloc stringAttemptRealloc
+#define uniCharStringCheckLimits stringCheckLimits
+#define SET_UNICHAR_STRING SET_STRING
+#define UNICHAR_STRING_SIZE STRING_SIZE
+
const Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
@@ -90,6 +107,148 @@ const Tcl_ObjType tclStringType = {
UpdateStringOfString, /* updateStringProc */
SetStringFromAny /* setFromAnyProc */
};
+
+#else
+
+#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
+
+#endif
/*
* TCL STRING GROWTH ALGORITHM
@@ -141,11 +300,11 @@ GrowStringBuffer(
* flag || objPtr->bytes != NULL
*/
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
char *ptr = NULL;
int attempt;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
@@ -177,6 +336,7 @@ GrowStringBuffer(
}
objPtr->bytes = ptr;
stringPtr->allocated = attempt;
+ memset(ptr + objPtr->length, 0, attempt + 1U - objPtr->length);
}
static void
@@ -188,10 +348,10 @@ GrowUnicodeBuffer(
* Preconditions:
* objPtr->typePtr == &tclStringType
* needed > stringPtr->maxChars
- * needed < STRING_MAXCHARS
+ * needed < UNICHAR_STRING_MAXCHARS
*/
- String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
+ UniCharString *ptr = NULL, *stringPtr = GET_UNICHAR_STRING(objPtr);
int attempt;
if (stringPtr->maxChars > 0) {
@@ -199,9 +359,9 @@ GrowUnicodeBuffer(
* Subsequent appends - apply the growth algorithm.
*/
- if (needed <= STRING_MAXCHARS / 2) {
+ if (needed <= UNICHAR_STRING_MAXCHARS / 2) {
attempt = 2 * needed;
- ptr = stringAttemptRealloc(stringPtr, attempt);
+ ptr = uniCharStringAttemptRealloc(stringPtr, attempt);
}
if (ptr == NULL) {
/*
@@ -209,13 +369,13 @@ GrowUnicodeBuffer(
* overflow into invalid argument values for attempt.
*/
- 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);
+ ptr = uniCharStringAttemptRealloc(stringPtr, attempt);
}
}
if (ptr == NULL) {
@@ -224,11 +384,11 @@ GrowUnicodeBuffer(
*/
attempt = needed;
- ptr = stringRealloc(stringPtr, attempt);
+ ptr = uniCharStringRealloc(stringPtr, attempt);
}
stringPtr = ptr;
stringPtr->maxChars = attempt;
- SET_STRING(objPtr, stringPtr);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
}
/*
@@ -262,7 +422,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 +434,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;
@@ -350,10 +509,8 @@ Tcl_DbNewStringObj(
* 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,7 +536,7 @@ 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
@@ -392,6 +549,39 @@ Tcl_NewUnicodeObj(
return objPtr;
}
+#if (TCL_UTF_MAX > 3) && !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
+
/*
*----------------------------------------------------------------------
*
@@ -410,11 +600,11 @@ Tcl_NewUnicodeObj(
*/
int
-Tcl_GetCharLength(
+TclGetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
* of. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
int numChars;
/*
@@ -427,20 +617,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,7 +637,7 @@ Tcl_GetCharLength(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
numChars = stringPtr->numChars;
/*
@@ -456,24 +645,53 @@ Tcl_GetCharLength(
*/
if (numChars == -1) {
- TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
+ TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
+ }
+ return numChars;
+}
+
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetCharLength
+int
+Tcl_GetCharLength(
+ Tcl_Obj *objPtr) /* The String object to get the num chars
+ * of. */
+{
+ int numChars;
-#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 = Tcl_NumUtfChars(objPtr->bytes, objPtr->length);
+ }
+
return numChars;
}
-
+#endif
+
+
/*
*----------------------------------------------------------------------
*
@@ -491,17 +709,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)
+ && Tcl_GetCharLength(objPtr) == 0) {
+ return TCL_EMPTYSTRING_YES;
+ }
+
+ if (TclListObjIsCanonical(objPtr)) {
+ TclListObjLengthM(NULL, objPtr, &length);
return length == 0;
}
@@ -519,10 +742,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 +757,19 @@ TclCheckEmptyString (
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+#if (TCL_UTF_MAX > 3) && !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,62 +778,64 @@ 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 (int) 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 (stringPtr->numChars == objPtr->length) {
- return (unsigned char) objPtr->bytes[index];
- }
- FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
-
if (index >= stringPtr->numChars) {
- return 0xFFFD;
+ return -1;
+ }
+ ch = stringPtr->unicode[index];
+ /* 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;
+ }
}
- return stringPtr->unicode[index];
+ 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;
}
/*
- * Optimize the case where we're really dealing with a ByteArray object
- * we don't need to convert to a string to perform the indexing operation.
+ * Optimize the ByteArray case: N need need to convert to a string to
+ * perform the indexing operation.
*/
if (TclIsPureByteArray(objPtr)) {
+ Tcl_Size length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
return -1;
@@ -621,7 +849,7 @@ TclGetUCS4(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
@@ -629,20 +857,20 @@ TclGetUCS4(
*/
if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
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
+#if TCL_UTF_MAX < 4
/* See: bug [11ae2be95dac9417] */
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x400) {
@@ -660,7 +888,6 @@ TclGetUCS4(
#endif
return ch;
}
-#endif
/*
*----------------------------------------------------------------------
@@ -681,18 +908,22 @@ TclGetUCS4(
*----------------------------------------------------------------------
*/
-Tcl_UniChar *
+#undef Tcl_GetUnicodeFromObj
+#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);
+ return TclGetUnicodeFromObj(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
@@ -709,21 +940,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) {
@@ -731,6 +962,52 @@ Tcl_GetUnicodeFromObj(
}
return stringPtr->unicode;
}
+
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
+unsigned short *
+Tcl_GetUnicodeFromObj(
+ 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;
+
+ SetUTF16StringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = stringPtr->numChars;
+ }
+ return stringPtr->unicode;
+}
+#endif
+
+#if !defined(TCL_NO_DEPRECATED)
+unsigned short *
+TclGetUnicodeFromObj(
+ Tcl_Obj *objPtr, /* The object to find the unicode string
+ * for. */
+ void *lengthPtr) /* If non-NULL, the location where the string
+ * rep's unichar length should be stored. If
+ * NULL, no length is stored. */
+{
+ String *stringPtr;
+
+#if TCL_UTF_MAX > 3
+ SetUTF16StringFromAny(NULL, objPtr);
+#else
+ SetStringFromAny(NULL, objPtr);
+#endif
+ stringPtr = GET_STRING(objPtr);
+
+ if (lengthPtr != NULL) {
+ *(ptrdiff_t *)lengthPtr = stringPtr->numChars;
+ }
+ return stringPtr->unicode;
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -739,9 +1016,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.
@@ -752,6 +1029,8 @@ Tcl_GetUnicodeFromObj(
*----------------------------------------------------------------------
*/
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetRange
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
@@ -759,7 +1038,53 @@ Tcl_GetRange(
int last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
- String *stringPtr;
+ int 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.
+ */
+
+ 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);
+ }
+
+ int numChars = Tcl_NumUtfChars(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. */
+ int first, /* First index of the range. */
+ int last) /* Last index of the range. */
+{
+ Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
+ UniCharString *stringPtr;
int length;
if (first < 0) {
@@ -789,15 +1114,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) {
@@ -814,14 +1139,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;
}
@@ -829,7 +1153,7 @@ Tcl_GetRange(
TclNewObj(newObjPtr);
return newObjPtr;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* See: bug [11ae2be95dac9417] */
if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
&& ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
@@ -841,7 +1165,7 @@ Tcl_GetRange(
++last;
}
#endif
- return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
+ return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}
/*
@@ -870,7 +1194,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.*/
{
@@ -882,7 +1206,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
@@ -901,20 +1225,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.
*
*----------------------------------------------------------------------
*/
@@ -923,20 +1246,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");
@@ -947,7 +1265,7 @@ Tcl_SetObjLength(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
@@ -957,7 +1275,7 @@ Tcl_SetObjLength(
/*
* Need to enlarge the buffer.
*/
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = (char *)ckalloc((unsigned int)length + 1U);
} else {
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, (unsigned int)length + 1U);
@@ -969,20 +1287,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;
}
@@ -1028,20 +1346,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");
}
@@ -1050,7 +1365,7 @@ Tcl_AttemptSetObjLength(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
@@ -1063,7 +1378,7 @@ Tcl_AttemptSetObjLength(
char *newBytes;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
newBytes = (char *)attemptckalloc((unsigned int)length + 1U);
} else {
newBytes = (char *)attemptckrealloc(objPtr->bytes, (unsigned int)length + 1U);
@@ -1082,22 +1397,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;
}
@@ -1133,33 +1448,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
* 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
+UTF16Length(
+ const unsigned short *ucs2Ptr)
+{
+ int 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;
}
@@ -1168,10 +1518,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);
@@ -1181,10 +1531,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));
@@ -1219,18 +1569,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);
@@ -1250,10 +1600,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;
}
/*
@@ -1267,8 +1617,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 {
@@ -1279,7 +1635,7 @@ Tcl_AppendLimitedToObj(
return;
}
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
@@ -1309,8 +1665,8 @@ 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);
@@ -1334,13 +1690,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");
@@ -1351,25 +1708,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 TCL_UTF_MAX > 3 && !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
+
/*
*----------------------------------------------------------------------
*
@@ -1395,8 +1777,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;
/*
@@ -1404,18 +1787,18 @@ 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
@@ -1436,7 +1819,7 @@ Tcl_AppendObjToObj(
* First, get the lengths.
*/
- int lengthSrc;
+ Tcl_Size lengthSrc;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
@@ -1459,7 +1842,7 @@ Tcl_AppendObjToObj(
*/
TclAppendBytesToByteArray(objPtr,
- Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
+ TclGetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
return;
}
@@ -1468,25 +1851,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 {
@@ -1505,19 +1891,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;
}
}
@@ -1543,10 +1925,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);
@@ -1556,7 +1938,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
@@ -1567,10 +1949,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
@@ -1584,7 +1966,7 @@ AppendUnicodeToUnicodeRep(
}
GrowUnicodeBuffer(objPtr, numChars);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* Relocate Unicode if needed; see above.
@@ -1632,23 +2014,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
}
/*
@@ -1673,9 +2047,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;
@@ -1683,7 +2057,7 @@ AppendUtfToUnicodeRep(
ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1);
TclInvalidateStringRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
stringPtr->allocated = 0;
}
@@ -1709,10 +2083,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;
@@ -1732,9 +2106,9 @@ AppendUtfToUtfRep(
}
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
@@ -1869,12 +2243,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";
@@ -1897,11 +2271,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);
@@ -2008,12 +2384,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 == '*') {
@@ -2022,7 +2402,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) {
@@ -2050,7 +2430,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 == '*') {
@@ -2059,7 +2448,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;
}
@@ -2096,6 +2485,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;
@@ -2117,12 +2525,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);
@@ -2137,13 +2545,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;
@@ -2151,14 +2560,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': {
@@ -2167,55 +2572,61 @@ 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);
@@ -2229,18 +2640,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;
@@ -2248,25 +2656,33 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
+#if TCL_MAJOR_VERSION < 9
+ case 'd':
+ if (gotZero) {
+ Tcl_AppendToObj(segment, "0d", 2);
+ segmentLimit -= 2;
+ }
+ break;
+#endif
}
}
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);
@@ -2298,7 +2714,7 @@ Tcl_AppendFormatToObj(
gotZero = 0;
}
if (gotZero) {
- length += Tcl_GetCharLength(segment);
+ length += TclGetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
@@ -2319,12 +2735,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;
+ int numBits = 4, base = 16, index = 0, shift = 0;
+ Tcl_Size length;
Tcl_Obj *pure;
char *bytes;
@@ -2355,7 +2773,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);
@@ -2384,7 +2802,7 @@ Tcl_AppendFormatToObj(
* Need to be sure zero becomes "0", not "".
*/
- if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ if (numDigits == 0) {
numDigits = 1;
}
TclNewObj(pure);
@@ -2394,7 +2812,7 @@ Tcl_AppendFormatToObj(
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;
@@ -2428,7 +2846,7 @@ Tcl_AppendFormatToObj(
gotZero = 0;
}
if (gotZero) {
- length += Tcl_GetCharLength(segment);
+ length += TclGetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
@@ -2451,6 +2869,8 @@ Tcl_AppendFormatToObj(
break;
}
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
@@ -2483,14 +2903,14 @@ 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);
+ p += snprintf(p, TCL_INTEGER_SPACE, "%" TCL_LL_MODIFIER "d", precision);
if (precision > INT_MAX - length) {
msg = overflow;
errCode = "OVERFLOW";
@@ -2519,6 +2939,12 @@ 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:
@@ -2531,7 +2957,7 @@ Tcl_AppendFormatToObj(
}
if (width>0 && numChars<0) {
- numChars = Tcl_GetCharLength(segment);
+ numChars = TclGetCharLength(segment);
}
if (!gotMinus && width>0) {
if (numChars < width) {
@@ -2610,7 +3036,7 @@ Tcl_Obj *
Tcl_Format(
Tcl_Interp *interp,
const char *format,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
int result;
@@ -2643,7 +3069,8 @@ AppendPrintfToObjVA(
const char *format,
va_list argList)
{
- int code, objc;
+ int code;
+ Tcl_Size objc;
Tcl_Obj **objv, *list;
const char *p;
@@ -2687,12 +3114,12 @@ AppendPrintfToObjVA(
* multi-byte characters.
*/
- q = TclUtfPrev(end, bytes);
+ q = Tcl_UtfPrev(end, bytes);
if (!Tcl_UtfCharComplete(q, (int)(end - q))) {
end = q;
}
- q = bytes + TCL_UTF_MAX;
+ q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
@@ -2703,6 +3130,11 @@ AppendPrintfToObjVA(
break;
}
+ case 'p':
+ if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ /* FALLTHRU */
case 'c':
case 'i':
case 'u':
@@ -2714,27 +3146,42 @@ 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));
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
p++;
break;
case '0': case '1': case '2': case '3': case '4':
@@ -2749,9 +3196,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':
@@ -2762,7 +3235,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,
@@ -2850,16 +3323,935 @@ TclGetStringStorage(
Tcl_Obj *objPtr,
unsigned int *sizePtr)
{
- String *stringPtr;
+ UniCharString *stringPtr;
- if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) {
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, (int *)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 (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", 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,
+ TclGetByteArrayFromObj(objResultPtr, 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", 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 %u bytes",
+ count*length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", 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) {
+ /* Negative (shouldn't be), one or no objects; return first or empty */
+ return objc == 1 ? objv[0] : Tcl_NewObj();
+ }
+
+ /* 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 > (INT_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 (numChars > INT_MAX - length) {
+ 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 > INT_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 > INT_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", 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", 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 %u bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", 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 %u bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", 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 (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", 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) && (TCL_UTF_MAX > 3)
+ 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 = Tcl_NumUtfChars(s1, s1len);
+ s2len = Tcl_NumUtfChars(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)
+{
+ int 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,
+ int 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;
+}
+
/*
*---------------------------------------------------------------------------
*
@@ -2868,9 +4260,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.
@@ -2882,7 +4274,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;
@@ -2904,44 +4296,48 @@ 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 inPlace = flags & TCL_STRING_IN_PLACE;
+#if TCL_UTF_MAX < 4
int needFlip = 0;
#endif
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(TclGetByteArrayFromObj(objPtr, 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
+#if TCL_UTF_MAX < 4
ch = *src;
if ((ch & 0xF800) == 0xD800) {
needFlip = 1;
@@ -2956,12 +4352,12 @@ TclStringReverse(
* Reversing in place.
*/
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
to = src;
#endif
while (--src > from) {
ch = *src;
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
if ((ch & 0xF800) == 0xD800) {
needFlip = 1;
}
@@ -2970,7 +4366,7 @@ TclStringReverse(
*from++ = ch;
}
}
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX < 4
if (needFlip) {
/*
* Flip back surrogate pairs.
@@ -2992,11 +4388,11 @@ TclStringReverse(
}
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);
}
@@ -3012,7 +4408,7 @@ TclStringReverse(
* Pass 1. Reverse the bytes of each multi-byte character.
*/
- int bytesLeft = numBytes;
+ Tcl_Size bytesLeft = numBytes;
int chw;
while (bytesLeft) {
@@ -3043,6 +4439,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 */
+ int first, /* First index to replace */
+ int 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 > (INT_MAX - (numBytes - count))) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded",
+ INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", 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
@@ -3062,7 +4602,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);
@@ -3072,25 +4612,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;
@@ -3099,9 +4639,22 @@ 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;
+#if TCL_UTF_MAX > 3
+ /* 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--;
+ }
+#endif
+ *dst++ = unichar;
+ while (numAppendChars-- > 0) {
+ bytes += TclUtfToUniChar(bytes, &unichar);
+ *dst++ = unichar;
+ }
}
*dst = 0;
}
@@ -3131,11 +4684,10 @@ 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
@@ -3153,17 +4705,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;
}
@@ -3177,44 +4729,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;
}
/*
@@ -3229,25 +4746,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
@@ -3258,8 +4775,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;
}
@@ -3286,7 +4803,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
@@ -3299,26 +4816,26 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, NULL, 0);
} 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);
@@ -3343,7 +4860,7 @@ ExtendStringRepWithUnicode(
}
for (i = 0; i < numChars && size >= 0; i++) {
- size += (unsigned int)Tcl_UniCharToUtf((int) unicode[i], buf);
+ size += (unsigned int)TclUtfCount(unicode[i]);
}
if (size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
@@ -3359,6 +4876,7 @@ ExtendStringRepWithUnicode(
copyBytes:
dst = objPtr->bytes + origLength;
+ *dst = '\0';
for (i = 0; i < numChars; i++) {
dst += Tcl_UniCharToUtf(unicode[i], dst);
}
@@ -3372,7 +4890,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..d1863fb 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,43 @@
* 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
+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 actually allocated for
+ * the UTF-8 string (minus 1 byte for the
* termination char). */
- int maxChars; /* Max number of chars that can fit in the
+ 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)
+ (int)(((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 +59,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 d6621b6..e2d52b9 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>
@@ -35,35 +36,241 @@
#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_GetRange
+#undef Tcl_GetUniChar
#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 Tcl_NumUtfChars
+#undef Tcl_GetCharLength
+#undef Tcl_UtfAtIndex
+#undef Tcl_GetRange
+#undef Tcl_GetUniChar
#undef TclObjInterpProc
+
+#if defined(_WIN32) || defined(__CYGWIN__)
+#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError
+#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError
+#endif
+
+
+#if TCL_UTF_MAX > 3 && 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 TclGetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, ptrdiff_t *))(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);
+}
+
+int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ void *objcPtr, Tcl_Obj ***objvPtr) {
+ int n, result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
+ if ((result == TCL_OK) && objcPtr) {
+ *(ptrdiff_t *)objcPtr = n;
+ }
+ return result;
+}
+int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ void *lengthPtr) {
+ int n;
+ int result = Tcl_ListObjLength(interp, listPtr, &n);
+ if ((result == TCL_OK) && lengthPtr) {
+ *(ptrdiff_t *)lengthPtr = n;
+ }
+ return result;
+}
+int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
+ void *sizePtr) {
+ int n, result = Tcl_DictObjSize(interp, dictPtr, &n);
+ if ((result == TCL_OK) && sizePtr) {
+ *(ptrdiff_t *)sizePtr = n;
+ }
+ return result;
+}
+int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
+ const char ***argvPtr) {
+ int n;
+ int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
+ if ((result == TCL_OK) && argcPtr) {
+ *(ptrdiff_t *)argcPtr = n;
+ }
+ return result;
+}
+void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) {
+ int n;
+ Tcl_SplitPath(path, &n, argvPtr);
+ if (argcPtr) {
+ *(ptrdiff_t *)argcPtr = n;
+ }
+}
+Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) {
+ int n;
+ Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
+ if (result && lenPtr) {
+ *(ptrdiff_t *)lenPtr = n;
+ }
+ return result;
+}
+int TclParseArgsObjv(Tcl_Interp *interp,
+ const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv,
+ Tcl_Obj ***remObjv) {
+ int n, result;
+ if (*(ptrdiff_t *)objcPtr > INT_MAX) {
+ if (interp) {
+ Tcl_AppendResult(interp, "Tcl_ParseArgsObjv cannot handle *objcPtr > INT_MAX", NULL);
+ }
+ return TCL_ERROR;
+ }
+ n = *(ptrdiff_t *)objcPtr;
+ result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
+ *(ptrdiff_t *)objcPtr = n;
+ return result;
+}
+
+#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 +280,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 +327,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,63 +487,36 @@ static const char *TclGetStartupScriptFileName(void)
}
return Tcl_GetString(path);
}
-
-/* (unsupported in Tcl 8.6) */
-
-#define TclGetStringFromObj_ getStringFromObj
-static char *
-TclGetStringFromObj_(
- Tcl_Obj *objPtr,
- void *lengthPtr)
-{
- int length;
- char *result = Tcl_GetStringFromObj(objPtr, &length);
- *(size_t *)lengthPtr = (size_t)length;
- return result;
-}
-
-#define TclGetUnicodeFromObj_ getUnicodeFromObj
-static unsigned short *
-TclGetUnicodeFromObj_(
- Tcl_Obj *objPtr,
- void *lengthPtr)
-{
- int length;
- Tcl_UniChar *result = Tcl_GetUnicodeFromObj(objPtr, &length);
- *(size_t *)lengthPtr = (size_t)length;
- return result;
-}
-
-#define TclGetByteArrayFromObj_ getByteArrayFromObj
-static unsigned char *
-TclGetByteArrayFromObj_(
- Tcl_Obj *objPtr,
- void *numBytesPtr)
-{
- int numBytes;
- unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
- *(size_t *)numBytesPtr = (size_t)numBytes;
- return result;
-}
-
-
#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
@@ -210,20 +532,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 *, unsigned int)) 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,
@@ -246,6 +565,7 @@ TclWinGetServByName(const char *name, const char *proto)
{
return getservbyname(name, proto);
}
+#endif /* TCL_NO_DEPRECATED */
#define TclWinNoBackslash winNoBackslash
static char *
@@ -265,7 +585,7 @@ void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
- (const char *)&TclWinNoBackslash, &hInstance);
+ (const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
@@ -275,134 +595,28 @@ TclpGetPid(Tcl_Pid pid)
return (int)(size_t)pid;
}
-static void
-doNothing(void)
-{
- /* dummy implementation, no need to do anything */
-}
-
+#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
@@ -410,33 +624,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 {
@@ -452,7 +644,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 {
@@ -464,10 +656,16 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
+#if TCL_UTF_MAX < 4 && !defined(TCL_NO_DEPRECATED)
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 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
+#endif
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
}
@@ -476,51 +674,176 @@ 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 */
+
+#endif /* __CYGWIN__ */
-#else /* UNIX and MAC */
+#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
+#if TCL_UTF_MAX < 4
+# define Tcl_GetUnicode 0
+# define Tcl_AppendUnicodeToObj 0
+# define Tcl_UniCharCaseMatch 0
+# define Tcl_UniCharNcasecmp 0
+# define Tcl_UniCharNcmp 0
+#endif
+# 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
@@ -531,6 +854,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 = {
@@ -579,7 +911,7 @@ static const TclIntStubs tclIntStubs = {
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
- 0, /* 43 */
+ TclGetObjInterpProc2, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
@@ -648,22 +980,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 */
@@ -714,8 +1046,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 */
@@ -786,18 +1118,18 @@ 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 */
- 0, /* 258 */
+ TclStaticLibrary, /* 257 */
+ TclpCreateTemporaryDirectory, /* 258 */
0, /* 259 */
- 0, /* 260 */
- TclUnusedStubEntry, /* 261 */
+ TclListTestObj, /* 260 */
+ TclListObjValidate, /* 261 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
@@ -911,12 +1243,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 */
};
@@ -942,7 +1274,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 */
@@ -970,12 +1302,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 */
@@ -984,16 +1316,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 */
@@ -1128,7 +1460,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 */
@@ -1195,7 +1527,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 */
@@ -1211,7 +1543,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 */
@@ -1283,7 +1615,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 */
@@ -1365,17 +1697,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 */
@@ -1391,10 +1723,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 */
@@ -1670,61 +2002,61 @@ 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 */
- 0, /* 650 */
- TclGetStringFromObj_, /* 651 */
- TclGetUnicodeFromObj_, /* 652 */
- TclGetByteArrayFromObj_, /* 653 */
- 0, /* 654 */
- 0, /* 655 */
- 0, /* 656 */
- 0, /* 657 */
- 0, /* 658 */
- 0, /* 659 */
- 0, /* 660 */
- 0, /* 661 */
- 0, /* 662 */
- 0, /* 663 */
- 0, /* 664 */
- 0, /* 665 */
- 0, /* 666 */
- 0, /* 667 */
- 0, /* 668 */
- 0, /* 669 */
- 0, /* 670 */
- 0, /* 671 */
- 0, /* 672 */
- 0, /* 673 */
- 0, /* 674 */
- 0, /* 675 */
- 0, /* 676 */
- 0, /* 677 */
- 0, /* 678 */
- 0, /* 679 */
- 0, /* 680 */
- 0, /* 681 */
- 0, /* 682 */
- 0, /* 683 */
- 0, /* 684 */
- 0, /* 685 */
+ 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 */
+ TclGetBytesFromObj, /* 649 */
+ Tcl_GetBytesFromObj, /* 650 */
+ TclGetStringFromObj, /* 651 */
+ TclGetUnicodeFromObj, /* 652 */
+ TclGetByteArrayFromObj, /* 653 */
+ Tcl_UtfCharComplete, /* 654 */
+ Tcl_UtfNext, /* 655 */
+ Tcl_UtfPrev, /* 656 */
+ Tcl_UniCharIsUnicode, /* 657 */
+ Tcl_ExternalToUtfDStringEx, /* 658 */
+ Tcl_UtfToExternalDStringEx, /* 659 */
+ Tcl_AsyncMarkFromSignal, /* 660 */
+ TclListObjGetElements, /* 661 */
+ TclListObjLength, /* 662 */
+ TclDictObjSize, /* 663 */
+ TclSplitList, /* 664 */
+ TclSplitPath, /* 665 */
+ TclFSSplitPath, /* 666 */
+ TclParseArgsObjv, /* 667 */
+ Tcl_UniCharLen, /* 668 */
+ TclNumUtfChars, /* 669 */
+ TclGetCharLength, /* 670 */
+ TclUtfAtIndex, /* 671 */
+ TclGetRange, /* 672 */
+ TclGetUniChar, /* 673 */
+ Tcl_GetBool, /* 674 */
+ Tcl_GetBoolFromObj, /* 675 */
+ Tcl_CreateObjCommand2, /* 676 */
+ Tcl_CreateObjTrace2, /* 677 */
+ Tcl_NRCreateCommand2, /* 678 */
+ Tcl_NRCallObjProc2, /* 679 */
+ 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 f227ec3..893f073 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,67 +181,76 @@ 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,
+static int ObjTraceProc(void *clientData,
Tcl_Interp *interp, int level, const char *command,
Tcl_Command commandToken, int objc,
Tcl_Obj *const objv[]);
-static void ObjTraceDeleteProc(ClientData clientData);
+static void ObjTraceDeleteProc(void *clientData);
static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static void SpecialFree(char *blockPtr);
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_ObjCmdProc Testutf16stringObjCmd;
static Tcl_CmdProc TestcmdinfoCmd;
static Tcl_CmdProc TestcmdtokenCmd;
static Tcl_CmdProc TestcmdtraceCmd;
@@ -228,7 +267,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 +280,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 +296,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 void TestsaveresultFree(char *blockPtr);
+#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_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;
@@ -321,6 +364,7 @@ static Tcl_ObjCmdProc TestNumUtfCharsCmd;
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;
@@ -432,14 +476,87 @@ 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
+#if TCL_UTF_MAX < 4
+ ".utf-16"
+#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
@@ -448,15 +565,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;
}
@@ -471,6 +599,7 @@ 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, "testutf16string", Testutf16stringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -539,6 +668,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",
@@ -546,6 +677,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);
@@ -556,12 +689,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,
@@ -586,15 +725,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,
@@ -605,17 +746,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);
@@ -625,7 +765,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;
}
@@ -655,7 +795,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);
}
@@ -694,9 +834,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);
}
@@ -719,7 +874,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. */
@@ -727,7 +882,6 @@ TestasyncCmd(
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- (void)dummy;
if (argc < 2) {
wrongNumArgs:
@@ -749,7 +903,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);
@@ -802,10 +956,9 @@ TestasyncCmd(
break;
}
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], TCL_INDEX_NONE));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
-#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
@@ -833,19 +986,13 @@ TestasyncCmd(
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);
- 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. */
@@ -877,7 +1024,7 @@ AsyncHandlerProc(
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
@@ -904,10 +1051,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;
@@ -926,11 +1072,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. */
@@ -965,13 +1110,12 @@ TestbumpinterpepochObjCmd(
static int
TestcmdinfoCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
- (void)dummy;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -979,7 +1123,7 @@ TestcmdinfoCmd(
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
+ Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original",
CmdDelProc1);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DStringInit(&delString);
@@ -1016,15 +1160,15 @@ TestcmdinfoCmd(
}
} else if (strcmp(argv[1], "modify") == 0) {
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";
+ info.deleteData = (void *) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(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],
@@ -1035,11 +1179,23 @@ TestcmdinfoCmd(
}
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, 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);
return TCL_OK;
@@ -1047,31 +1203,53 @@ CmdProc1(
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);
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);
- Tcl_DStringAppend(&delString, (char *) clientData, -1);
+ Tcl_DStringAppend(&delString, "CmdDelProc1 ", TCL_INDEX_NONE);
+ Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
static void
CmdDelProc2(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
- Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
- Tcl_DStringAppend(&delString, (char *) clientData, -1);
+ Tcl_DStringAppend(&delString, "CmdDelProc2 ", TCL_INDEX_NONE);
+ Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
/*
@@ -1093,13 +1271,13 @@ 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) {
@@ -1108,31 +1286,53 @@ TestcmdtokenCmd(
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 *)Tcl_Alloc(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, NULL);
+ } else {
+ if (sscanf(argv[2], "%d", &id) != 1) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", 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],
+ "\"", 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", NULL);
+ return TCL_ERROR;
+ }
}
+
return TCL_OK;
}
@@ -1156,7 +1356,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. */
@@ -1173,7 +1373,7 @@ TestcmdtraceCmd(
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);
@@ -1189,13 +1389,13 @@ 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);
@@ -1213,7 +1413,7 @@ TestcmdtraceCmd(
cmdTrace = Tcl_CreateObjTrace(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);
@@ -1227,7 +1427,7 @@ 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);
@@ -1245,16 +1445,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. */
{
@@ -1272,16 +1471,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
@@ -1294,18 +1491,18 @@ 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(int) /*level*/,
+ const char *command,
+ TCL_UNUSED(Tcl_Command),
+ TCL_UNUSED(int) /*objc*/,
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(command, TCL_INDEX_NONE));
return TCL_ERROR;
} else if (!strcmp(word, "Break")) {
return TCL_BREAK;
@@ -1322,7 +1519,7 @@ ObjTraceProc(
static void
ObjTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
@@ -1351,7 +1548,7 @@ 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. */
@@ -1381,10 +1578,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;
@@ -1403,10 +1600,10 @@ CreatedCommandProc(
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;
@@ -1441,7 +1638,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. */
@@ -1473,7 +1670,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);
@@ -1505,7 +1702,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. */
@@ -1535,10 +1732,10 @@ 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;
@@ -1550,11 +1747,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);
@@ -1580,7 +1777,7 @@ 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. */
@@ -1609,7 +1806,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.
*
*-----------------------------------------------------------------------------
@@ -1617,21 +1814,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
};
@@ -1655,8 +1850,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));
}
@@ -1671,16 +1866,16 @@ TestdoubledigitsObjCmd(
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", TCL_INDEX_NONE));
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);
@@ -1706,7 +1901,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. */
@@ -1774,12 +1969,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;
@@ -1795,8 +1995,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", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1848,14 +2048,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;
@@ -1863,7 +2063,7 @@ static int UtfExtWrapper(
int result;
int flags;
Tcl_Obj **flagObjs;
- int nflags;
+ Tcl_Size nflags;
static const struct {
const char *flagKey;
int flag;
@@ -1873,9 +2073,12 @@ static int UtfExtWrapper(
{"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) {
@@ -1984,19 +2187,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);
@@ -2060,7 +2263,7 @@ 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. */
@@ -2070,10 +2273,10 @@ TestencodingObjCmd(
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
};
if (objc < 2) {
@@ -2126,7 +2329,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:
@@ -2137,11 +2356,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. */
@@ -2152,7 +2371,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) {
@@ -2169,11 +2388,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. */
@@ -2184,7 +2403,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) {
@@ -2201,7 +2420,7 @@ EncodingFromUtfProc(
static void
EncodingFreeProc(
- ClientData clientData) /* ClientData associated with type. */
+ void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = (TclEncoding *)clientData;
@@ -2229,12 +2448,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;
@@ -2274,7 +2494,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. */
@@ -2323,7 +2543,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 */
@@ -2336,7 +2556,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,
@@ -2408,7 +2628,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;
@@ -2420,14 +2640,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) {
@@ -2459,7 +2679,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 */
@@ -2502,7 +2722,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. */
@@ -2533,7 +2753,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;
@@ -2547,7 +2767,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;
@@ -2578,7 +2798,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. */
@@ -2621,7 +2841,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. */
@@ -2663,7 +2883,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. */
@@ -2707,7 +2927,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. */
@@ -2749,7 +2969,7 @@ 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. */
@@ -2781,7 +3001,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. */
@@ -2848,7 +3068,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. */
@@ -2886,7 +3106,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. */
@@ -2926,7 +3146,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. */
@@ -2966,7 +3186,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. */
@@ -3025,7 +3245,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;
}
@@ -3033,7 +3253,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;
}
@@ -3041,7 +3261,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;
}
@@ -3049,7 +3269,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;
}
@@ -3057,7 +3277,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;
}
@@ -3065,7 +3285,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;
}
@@ -3073,7 +3293,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;
}
@@ -3081,7 +3301,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;
}
@@ -3089,7 +3309,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;
}
@@ -3097,7 +3317,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;
}
@@ -3105,7 +3325,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;
}
@@ -3113,7 +3333,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;
}
@@ -3121,7 +3341,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;
}
@@ -3129,7 +3349,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;
}
@@ -3174,15 +3394,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) {
@@ -3223,7 +3460,7 @@ TestlinkCmd(
}
}
if (argv[6][0] != 0) {
- tmp = Tcl_NewStringObj(argv[6], -1);
+ tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3281,7 +3518,7 @@ TestlinkCmd(
}
if (argv[15][0]) {
Tcl_WideInt w;
- tmp = Tcl_NewStringObj(argv[15], -1);
+ tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3331,7 +3568,7 @@ TestlinkCmd(
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
- tmp = Tcl_NewStringObj(argv[6], -1);
+ tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3398,7 +3635,7 @@ TestlinkCmd(
}
if (argv[15][0]) {
Tcl_WideInt w;
- tmp = Tcl_NewStringObj(argv[15], -1);
+ tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3418,75 +3655,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", TCL_INDEX_NONE));
+ return TCL_ERROR;
+ }
+ name = Tcl_GetString(objv[i++]);
+
+ /*
+ * If no address is given request one in the underlying function
+ */
+
+ if (i < objc) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong address value", TCL_INDEX_NONE));
+ return TCL_ERROR;
+ }
+ } else {
+ addr = 0;
+ }
+ return Tcl_LinkArray(interp, name, INT2PTR(addr),
+ LinkTypes[typeIndex] | readonly, size);
}
return TCL_OK;
+
+ wrongArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
+ return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * 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.
@@ -3495,122 +3789,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 */
+ const char* subcommands[] = {
+ "new",
+ "describe",
+ "config",
+ "validate",
+ NULL
+ };
+ enum {
+ LISTREP_NEW,
+ LISTREP_DESCRIBE,
+ LISTREP_CONFIG,
+ LISTREP_VALIDATE
+ } cmdIndex;
+ Tcl_Obj *resultObj = NULL;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(
+ interp, objv[1], subcommands, "command", 0, &cmdIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (cmdIndex) {
+ case LISTREP_NEW:
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?");
+ return TCL_ERROR;
+ } else {
+ 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", NULL);
+ return TCL_ERROR;
+ }
+ }
+ break;
+
+ case LISTREP_DESCRIBE:
+#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
+ do { \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewStringObj(#fld_, TCL_INDEX_NONE)); \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
+ } while (0)
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **objs;
+ 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", TCL_INDEX_NONE);
+ listRepObjs[1] = Tcl_NewListObj(12, NULL);
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
+ if (listRep.spanPtr) {
+ listRepObjs[2] = Tcl_NewStringObj("span", TCL_INDEX_NONE);
+ listRepObjs[3] = Tcl_NewListObj(8, NULL);
+ Tcl_ListObjAppendElement(interp,
+ listRepObjs[3],
+ Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
+ APPEND_FIELD(
+ listRepObjs[3], listRep.spanPtr, spanLength);
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
+ }
+ resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
+ }
+#undef APPEND_FIELD
+ break;
+
+ case LISTREP_CONFIG:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewListObj(2, NULL);
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
+ break;
+
+ case LISTREP_VALIDATE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ TclListObjValidate(interp, objv[2]); /* Panics if invalid */
+ resultObj = Tcl_NewObj();
+ break;
+ }
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * 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, TCL_INDEX_NONE);
+ }
+ return TCL_OK;
}
/*
@@ -3632,8 +4007,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);
}
@@ -3657,13 +4032,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) {
@@ -3713,13 +4089,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) {
@@ -3794,7 +4171,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) {
@@ -3830,16 +4207,16 @@ PrintParse(
break;
}
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewStringObj(typeString, -1));
+ Tcl_NewStringObj(typeString, TCL_INDEX_NONE));
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());
}
/*
@@ -3861,7 +4238,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. */
@@ -3902,13 +4279,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) {
@@ -3948,6 +4326,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
@@ -3966,12 +4414,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;
@@ -4080,17 +4529,17 @@ 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);
@@ -4104,7 +4553,7 @@ 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);
@@ -4124,19 +4573,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 : 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;
@@ -4151,12 +4600,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) {
@@ -4176,7 +4625,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;
}
@@ -4200,11 +4649,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;
@@ -4289,10 +4739,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;
}
@@ -4317,7 +4767,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. */
@@ -4368,7 +4818,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. */
@@ -4400,10 +4850,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.
@@ -4416,8 +4866,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. */
@@ -4435,7 +4885,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;
}
@@ -4445,7 +4895,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;
}
@@ -4468,7 +4918,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. */
@@ -4509,7 +4959,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. */
@@ -4528,7 +4978,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;
@@ -4561,7 +5011,7 @@ 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. */
@@ -4613,7 +5063,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. */
@@ -4641,7 +5091,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. */
@@ -4662,7 +5112,7 @@ TestfeventCmd(
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 {
@@ -4713,19 +5163,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);
@@ -4734,7 +5182,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. */
@@ -4816,7 +5264,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. */
@@ -4877,7 +5325,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.
@@ -4890,10 +5338,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;
@@ -4902,8 +5350,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");
@@ -4960,15 +5406,15 @@ GetTimesObjCmd(
ckfree(objv);
/* TclGetString 100000 times */
- fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
- objPtr = Tcl_NewStringObj("12345", -1);
+ fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
+ objPtr = Tcl_NewStringObj("12345", TCL_INDEX_NONE);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
- fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n",
+ fprintf(stderr, " %.3f usec per Tcl_GetStringFromObj of \"12345\"\n",
timePer/100000);
/* Tcl_GetIntFromObj 100000 times */
@@ -5021,10 +5467,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;
}
@@ -5038,7 +5484,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;
}
@@ -5071,10 +5517,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;
}
@@ -5098,10 +5544,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;
}
@@ -5123,14 +5569,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");
@@ -5164,13 +5609,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?");
@@ -5212,14 +5656,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");
@@ -5228,12 +5671,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", NULL);
+ return TCL_ERROR;
}
- Tcl_SetByteArrayLength(obj, n);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -5257,21 +5705,23 @@ 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;
+ size_t n = 0;
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);
+ p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &n);
+ if (p == NULL) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
@@ -5279,6 +5729,43 @@ TestbytestringObjCmd(
/*
*----------------------------------------------------------------------
*
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
@@ -5295,7 +5782,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. */
@@ -5327,7 +5814,7 @@ TestsetCmd(
}
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. */
@@ -5375,9 +5862,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. */
@@ -5409,16 +5897,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", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
- char *buf = ckalloc(200);
+ char *buf = (char *)ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
@@ -5428,18 +5917,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) {
@@ -5451,11 +5939,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:
@@ -5486,10 +5972,11 @@ TestsaveresultCmd(
static void
TestsaveresultFree(
- char *blockPtr)
+ TCL_UNUSED(char *))
{
freeCount++;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5510,10 +5997,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());
@@ -5571,10 +6058,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);
@@ -5600,10 +6087,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;
@@ -5628,7 +6115,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. */
@@ -5693,7 +6180,7 @@ TestChannelCmd(
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
- Tcl_Obj *msg = Tcl_NewStringObj(argv[3], -1);
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelError(chan, msg);
@@ -5706,7 +6193,7 @@ TestChannelCmd(
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
- Tcl_Obj *msg = Tcl_NewStringObj(argv[3], -1);
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelErrorInterp(interp, msg);
@@ -5905,6 +6392,45 @@ TestChannelCmd(
return TCL_OK;
}
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", 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",
+ (char *) 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",
+ (char *) 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);
@@ -6054,7 +6580,7 @@ TestChannelCmd(
}
return TclChannelTransform(interp, chan,
- Tcl_NewStringObj(argv[4], -1));
+ Tcl_NewStringObj(argv[4], TCL_INDEX_NONE));
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
@@ -6095,7 +6621,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. */
@@ -6145,7 +6671,7 @@ TestChannelEventCmd(
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
- esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
+ esPtr->scriptPtr = Tcl_NewStringObj(argv[4], TCL_INDEX_NONE);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
@@ -6212,10 +6738,10 @@ TestChannelEventCmd(
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
+ (esPtr->mask == TCL_READABLE) ? "readable" : "writable", TCL_INDEX_NONE));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
- Tcl_NewStringObj("none", -1));
+ Tcl_NewStringObj("none", TCL_INDEX_NONE));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
@@ -6291,6 +6817,86 @@ TestChannelEventCmd(
/*
*----------------------------------------------------------------------
*
+ * 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..?\"", 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\"", NULL);
+ return TCL_ERROR;
+ }
+ hChannel = Tcl_GetChannel(interp, argv[2], &modePtr);
+ if ( NULL == hChannel ) {
+ Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL);
+ return TCL_ERROR;
+ }
+ statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
+ if ( NULL == statePtr) {
+ Tcl_AppendResult(interp, "No channel instance data:", argv[2],
+ NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[3], &testMode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (testMode) {
+ statePtr->flags |= TCP_ASYNC_TEST_MODE;
+ } else {
+ statePtr->flags &= ~TCP_ASYNC_TEST_MODE;
+ }
+ return TCL_OK;
+ }
+
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
+ "testflags", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestServiceModeCmd --
*
* This procedure implements the "testservicemode" command which gets or
@@ -6310,7 +6916,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. */
@@ -6332,7 +6938,7 @@ TestServiceModeCmd(
Tcl_SetServiceMode(TCL_SERVICE_ALL);
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode));
return TCL_OK;
}
@@ -6354,19 +6960,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;
}
@@ -6406,7 +7012,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. */
@@ -6414,7 +7020,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?");
@@ -6426,13 +7033,17 @@ 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", 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);
snprintf(buffer, sizeof(buffer), "%d", target);
@@ -6463,7 +7074,7 @@ TestGetIndexFromObjStructObjCmd(
static int
TestFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6485,14 +7096,14 @@ TestFilesystemObjCmd(
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
static Tcl_Obj *lastPathPtr = NULL;
Tcl_Obj *newPathPtr;
@@ -6532,7 +7143,7 @@ TestReportGetNativePath(
static void
TestReportFreeInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
@@ -6542,9 +7153,9 @@ TestReportFreeInternalRep(
}
}
-static ClientData
+static void *
TestReportDupInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
@@ -6567,7 +7178,7 @@ TestReport(
Tcl_DString ds;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
+ Tcl_DStringAppend(&ds, "lappend filesystemReport ", TCL_INDEX_NONE);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
@@ -6580,7 +7191,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);
@@ -6794,7 +7405,7 @@ TestReportUtime(
static int
TestReportNormalizePath(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
@@ -6805,7 +7416,7 @@ TestReportNormalizePath(
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ TCL_UNUSED(void **))
{
const char *str = Tcl_GetString(pathPtr);
@@ -6834,7 +7445,7 @@ SimplePathInFilesystem(
static int
TestSimpleFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6856,7 +7467,7 @@ TestSimpleFilesystemObjCmd(
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
@@ -6869,7 +7480,7 @@ static Tcl_Obj *
SimpleRedirect(
Tcl_Obj *pathPtr) /* Name of file to copy. */
{
- int len;
+ Tcl_Size len;
const char *str;
Tcl_Obj *origPtr;
@@ -6883,7 +7494,7 @@ SimpleRedirect(
Tcl_IncrRefCount(pathPtr);
return pathPtr;
}
- origPtr = Tcl_NewStringObj(str+10, -1);
+ origPtr = Tcl_NewStringObj(str+10, TCL_INDEX_NONE);
Tcl_IncrRefCount(origPtr);
return origPtr;
}
@@ -6915,7 +7526,7 @@ SimpleMatchInDirectory(
origPtr = SimpleRedirect(dirPtr);
res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types);
if (res == TCL_OK) {
- int gLength, j;
+ size_t gLength, j;
Tcl_ListObjLength(NULL, resPtr, &gLength);
for (j = 0; j < gLength; j++) {
Tcl_Obj *gElt, *nElt;
@@ -6983,7 +7594,7 @@ SimpleListVolumes(void)
/* Add one new volume */
Tcl_Obj *retVal;
- retVal = Tcl_NewStringObj("simplefs:/", -1);
+ retVal = Tcl_NewStringObj("simplefs:/", TCL_INDEX_NONE);
Tcl_IncrRefCount(retVal);
return retVal;
}
@@ -6991,65 +7602,39 @@ 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 */
+ int 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 (numBytes + 4U > sizeof(buffer)) {
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 */
@@ -7071,7 +7656,7 @@ TestUtfNextCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(first - buffer - 1));
return TCL_OK;
}
@@ -7083,12 +7668,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;
@@ -7100,7 +7685,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) {
@@ -7112,8 +7697,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;
}
@@ -7123,17 +7708,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) {
@@ -7141,7 +7726,7 @@ TestNumUtfCharsCmd(
}
}
len = Tcl_NumUtfChars(bytes, limit);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len));
}
return TCL_OK;
}
@@ -7152,7 +7737,7 @@ TestNumUtfCharsCmd(
static int
TestFindFirstCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7163,7 +7748,7 @@ TestFindFirstCmd(
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
@@ -7174,7 +7759,7 @@ TestFindFirstCmd(
static int
TestFindLastCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7185,11 +7770,38 @@ TestFindLastCmd(
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
+ }
+ 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)
/*
*----------------------------------------------------------------------
@@ -7216,13 +7828,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) {
@@ -7232,14 +7844,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));
+ Tcl_NewStringObj("operation not available", TCL_INDEX_NONE));
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;
@@ -7252,7 +7864,7 @@ TestcpuidCmd(
static int
TestHashSystemHashCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7264,7 +7876,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;
@@ -7281,8 +7892,8 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", -1);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7298,14 +7909,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", TCL_INDEX_NONE);
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", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7329,15 +7940,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", NULL);
return TCL_ERROR;
} else {
int val, i, total=0;
@@ -7348,19 +7957,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", 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*/)
{
int none;
- (void)result;
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
@@ -7373,9 +7999,9 @@ NREUnwind_callback(
&none, 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 *) &none - (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 *) &none - (char *) data[0]));
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
@@ -7383,15 +8009,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.
@@ -7405,10 +8027,10 @@ 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;
@@ -7416,9 +8038,6 @@ TestNRELevels(
Tcl_Obj *levels[6];
int i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
- (void)dummy;
- (void)objc;
- (void)objv;
if (refDepth == NULL) {
refDepth = &depth;
@@ -7426,18 +8045,18 @@ TestNRELevels(
depth = (refDepth - &depth);
- 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;
@@ -7464,13 +8083,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;
+ size_t len;
Tcl_Obj *objv[3];
/*
@@ -7479,23 +8099,17 @@ TestconcatobjCmd(
*/
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));
+ Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", TCL_INDEX_NONE));
emptyPtr = Tcl_NewObj();
- list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
+ list1Ptr = Tcl_NewStringObj("foo bar sum", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list1Ptr, &len);
- if (list1Ptr->bytes != NULL) {
- ckfree(list1Ptr->bytes);
- list1Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list1Ptr);
- list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
+ list2Ptr = Tcl_NewStringObj("eeny meeny", TCL_INDEX_NONE);
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
@@ -7744,6 +8358,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
@@ -7761,13 +8441,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;
+ size_t count = objc;
Tcl_Obj **remObjv, *result[3];
Tcl_ArgvInfo argTable[] = {
{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
@@ -7778,8 +8458,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);
@@ -7794,8 +8474,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;
@@ -7804,8 +8484,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:
@@ -7887,11 +8565,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.
@@ -7931,7 +8609,7 @@ MyCompiledVarFree(
}
#define TclVarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static Tcl_Var
MyCompiledVarFetch(
@@ -7980,10 +8658,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') {
@@ -7992,7 +8670,7 @@ InterpCompiledVarResolver(
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
resVarInfo->var = NULL;
- resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ resVarInfo->nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
Tcl_IncrRefCount(resVarInfo->nameObj);
*rPtr = &resVarInfo->vInfo;
return TCL_OK;
@@ -8002,7 +8680,7 @@ InterpCompiledVarResolver(
static int
TestInterpResolverCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8064,10 +8742,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];
@@ -8076,12 +8754,12 @@ int TestApplyLambdaObjCmd (
/* Create a lambda {{} {set a 42}} */
lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
- lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */
+ lambdaObjs[1] = Tcl_NewStringObj("set a 42", TCL_INDEX_NONE); /* Body */
lambdaObj = Tcl_NewListObj(2, lambdaObjs);
Tcl_IncrRefCount(lambdaObj);
/* Create the command "apply {{} {set a 42}" */
- evalObjs[0] = Tcl_NewStringObj("apply", -1);
+ evalObjs[0] = Tcl_NewStringObj("apply", TCL_INDEX_NONE);
Tcl_IncrRefCount(evalObjs[0]);
/*
* NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 3003487..0f5f21f 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);
}
@@ -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");
@@ -186,13 +188,13 @@ TestbignumobjCmd(
string = Tcl_GetString(objv[3]);
if (mp_init(&bignumValue) != MP_OKAY) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("error in mp_init", -1));
+ Tcl_NewStringObj("error in mp_init", TCL_INDEX_NONE));
return TCL_ERROR;
}
if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("error in mp_read_radix", -1));
+ Tcl_NewStringObj("error in mp_read_radix", TCL_INDEX_NONE));
return TCL_ERROR;
}
@@ -236,7 +238,7 @@ TestbignumobjCmd(
if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("error in mp_mul_d", -1));
+ Tcl_NewStringObj("error in mp_mul_d", TCL_INDEX_NONE));
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
@@ -261,7 +263,7 @@ TestbignumobjCmd(
if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("error in mp_div_d", -1));
+ Tcl_NewStringObj("error in mp_div_d", TCL_INDEX_NONE));
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
@@ -286,13 +288,13 @@ TestbignumobjCmd(
if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("error in mp_mod_2d", -1));
+ Tcl_NewStringObj("error in mp_mod_2d", TCL_INDEX_NONE));
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;
}
@@ -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;
}
@@ -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,23 +590,23 @@ 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;
}
if (objc < 5) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", TCL_INDEX_NONE);
return TCL_ERROR;
}
@@ -616,32 +617,18 @@ TestindexobjCmd(
return TCL_ERROR;
}
- argv = ckalloc((objc-3) * sizeof(char *));
+ argv = (const char **)ckalloc(((unsigned)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"), TCL_INDEX_NONE);
} 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]), TCL_INDEX_NONE);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
@@ -793,19 +775,19 @@ TestintobjCmd(
goto wrongNumArgs;
}
#if (INT_MAX == LONG_MAX) /* int is same size as long int */
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", TCL_INDEX_NONE);
#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);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", TCL_INDEX_NONE);
return TCL_OK;
}
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", TCL_INDEX_NONE);
#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
@@ -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,14 +813,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 {
@@ -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,40 @@ 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 */
- const char* subcommands[] = {
+ const char* const subcommands[] = {
"set",
"get",
- "replace"
+ "replace",
+ "indexmemcheck",
+ "getelementsmemcheck",
+ 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,
+ } 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 +948,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 +958,56 @@ 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;
}
return TCL_OK;
}
@@ -967,15 +1031,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;
+ const char *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 +1061,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", TCL_INDEX_NONE));
+ } 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, TCL_INDEX_NONE));
+ }
}
- 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", 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);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", TCL_INDEX_NONE);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "int", TCL_INDEX_NONE);
+#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;
+ varPtr[varIndex]->typePtr->name, TCL_INDEX_NONE);
}
- } 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 +1252,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 +1278,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 +1291,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 +1306,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 */
@@ -1272,14 +1353,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]), TCL_INDEX_NONE);
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 +1367,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 = -1;
+ }
} else {
length = -1;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
@@ -1310,12 +1394,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 +1413,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 +1425,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 = -1;
+ }
} else {
length = -1;
}
- 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 +1467,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));
+ "index value out of range", TCL_INDEX_NONE));
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 +1498,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));
+ "index value out of range", TCL_INDEX_NONE));
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 +1556,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,19 +1587,19 @@ 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);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", TCL_INDEX_NONE);
return TCL_ERROR;
}
@@ -1530,14 +1629,14 @@ 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) {
char buf[32 + TCL_INTEGER_SPACE];
snprintf(buf, sizeof(buf), "variable %d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, TCL_INDEX_NONE);
return 1;
}
return 0;
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 45dea21..b6dbc3f 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";
/*
@@ -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;
}
@@ -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 */
@@ -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 */
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 d6d89a1..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 by 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.
@@ -230,7 +230,7 @@ TclRememberJoinableThread(
{
JoinableThread *threadPtr;
- threadPtr = ckalloc(sizeof(JoinableThread));
+ threadPtr = (JoinableThread *)ckalloc(sizeof(JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
@@ -305,6 +305,8 @@ TclSignalExitThread(
Tcl_MutexUnlock(&threadPtr->threadMutex);
}
+#else
+TCL_MAC_EMPTY_FILE(generic_tclThreadJoin_c)
#endif /* _WIN32 */
/*
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..44d2b0e 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,13 +363,13 @@ 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);
+ snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", (long long)id);
Tcl_AppendResult(interp, "cannot join thread ", buf, 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,7 +505,7 @@ 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);
@@ -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,15 +651,15 @@ 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);
- Tcl_WriteChars(errChannel, buf, -1);
+ Tcl_WriteChars(errChannel, "Error from thread ", TCL_INDEX_NONE);
+ Tcl_WriteChars(errChannel, buf, TCL_INDEX_NONE);
Tcl_WriteChars(errChannel, "\n", 1);
- Tcl_WriteChars(errChannel, errorInfo, -1);
+ Tcl_WriteChars(errChannel, errorInfo, TCL_INDEX_NONE);
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
@@ -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);
@@ -988,7 +984,7 @@ ThreadCancel(
Tcl_MutexUnlock(&threadMutex);
Tcl_ResetResult(interp);
return Tcl_CancelEval(tsdPtr->interp,
- (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
+ (result != NULL) ? Tcl_NewStringObj(result, TCL_INDEX_NONE) : NULL, 0, flags);
}
/*
@@ -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..e986db7 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,15 +817,9 @@ 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(
@@ -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];
@@ -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..26db082 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -1,1131 +1,55 @@
-/* LibTomMath, multiple-precision integer library -- Tom St Denis */
-/* SPDX-License-Identifier: Unlicense */
+#ifndef BN_TCL_H_
+#define BN_TCL_H_
-#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
+#ifdef MP_NO_STDINT
+# ifdef HAVE_STDINT_H
+# include <stdint.h>
# else
-/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
-# define MP_DIGIT_BIT 28
-# define MP_28BIT
+# include "../compat/stdint.h"
# 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 */
+#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);
+#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
+# include "tommath.h"
#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;
-*/
-#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..009f914 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
@@ -42,51 +43,86 @@
/* 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)
+#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 442ce02..0b1606a 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_REMOVE_OBSOLETE_TRACES
+ ,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,12 +190,11 @@ 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
const char *name;
const char *flagOps, *p;
@@ -202,13 +207,7 @@ Tcl_TraceObjCmd(
#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;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
@@ -219,7 +218,7 @@ Tcl_TraceObjCmd(
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum traceOptions) optionIndex) {
+ switch ((enum traceOptionsEnum) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
/*
@@ -238,7 +237,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,7 +260,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);
break;
}
@@ -270,8 +269,7 @@ Tcl_TraceObjCmd(
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 +278,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 +312,7 @@ Tcl_TraceObjCmd(
return code;
}
case TRACE_OLD_VINFO: {
- ClientData clientData;
+ void *clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
@@ -399,16 +397,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 +410,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 +429,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;
}
@@ -446,6 +441,10 @@ TraceExecutionObjCmd(
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 +465,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 +495,7 @@ TraceExecutionObjCmd(
* first one that matches.
*/
- ClientData clientData;
+ void *clientData;
/*
* First ensure the name given is valid.
@@ -556,7 +554,7 @@ TraceExecutionObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
+ void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -576,7 +574,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 +602,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 +619,10 @@ TraceExecutionObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -647,22 +649,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 +676,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;
}
@@ -687,7 +688,10 @@ TraceCommandObjCmd(
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 +707,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 +733,7 @@ TraceCommandObjCmd(
* first one that matches.
*/
- ClientData clientData;
+ void *clientData;
/*
* First ensure the name given is valid.
@@ -760,7 +763,7 @@ TraceCommandObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
+ void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -779,7 +782,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 +802,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 +818,10 @@ TraceCommandObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -841,27 +848,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 +880,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;
}
@@ -886,6 +892,10 @@ TraceVariableObjCmd(
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,11 +916,10 @@ 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;
@@ -1007,6 +1016,10 @@ TraceVariableObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -1036,14 +1049,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 +1123,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 +1187,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 +1292,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 +1433,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 +1538,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 +1685,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 +1732,7 @@ CallTraceFunction(
static void
CommandObjTraceDeleted(
- ClientData clientData)
+ void *clientData)
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -1757,12 +1768,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 +1828,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 +1976,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
@@ -1979,7 +1991,7 @@ TraceVarProc(
int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
- * We might call Tcl_Eval() below, and that might evaluate [trace vdelete]
+ * We might call Tcl_EvalEx() below, and that might evaluate [trace vdelete]
* which might try to free tvarPtr. We want to use tvarPtr until the end
* of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
* it is not freed while we still need it.
@@ -2073,7 +2085,7 @@ TraceVarProc(
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateObjTrace --
+ * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 --
*
* Arrange for a function to be called to trace command execution.
*
@@ -2086,7 +2098,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,
@@ -2125,13 +2137,64 @@ TraceVarProc(
*----------------------------------------------------------------------
*/
+typedef struct {
+ Tcl_CmdObjTraceProc2 *proc;
+ Tcl_CmdObjTraceDeleteProc *delProc;
+ void *clientData;
+} TraceWrapperInfo;
+
+static int traceWrapperProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ Tcl_Size level,
+ const char *command,
+ Tcl_Command commandInfo,
+ Tcl_Size objc,
+ Tcl_Obj *const objv[])
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
+ if (objc < 0) {
+ objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */
+ }
+ return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv);
+}
+
+static void traceWrapperDelProc(void *clientData)
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
+ clientData = info->clientData;
+ if (info->delProc) {
+ info->delProc(clientData);
+ }
+ ckfree(info);
+}
+
+Tcl_Trace
+Tcl_CreateObjTrace2(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ Tcl_Size level, /* Maximum nesting level */
+ int flags, /* Flags, see above */
+ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */
+ void *clientData, /* Client data for the callback */
+ Tcl_CmdObjTraceDeleteProc *delProc)
+ /* Function to call when trace is deleted */
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)ckalloc(sizeof(TraceWrapperInfo));
+ info->proc = proc;
+ info->delProc = delProc;
+ info->clientData = clientData;
+ return Tcl_CreateObjTrace(interp, level, flags,
+ (proc ? traceWrapperProc : NULL),
+ info, traceWrapperDelProc);
+}
+
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
- int level, /* Maximum nesting level */
+ 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 +2254,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 +2280,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 +2312,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 +2368,7 @@ StringTraceProc(
static void
StringTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
ckfree(clientData);
}
@@ -2558,6 +2621,9 @@ TclObjCallVarTraces(
leaveErrMsg);
}
+#undef TCL_INTERP_DESTROYED
+#define TCL_INTERP_DESTROYED 0x100
+
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
@@ -2855,6 +2921,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
@@ -2870,6 +2937,7 @@ Tcl_UntraceVar(
{
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3024,6 +3092,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
@@ -3041,6 +3110,7 @@ Tcl_VarTraceInfo(
return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
prevClientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3133,6 +3203,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_TraceVar
int
Tcl_TraceVar(
@@ -3150,6 +3221,7 @@ Tcl_TraceVar(
{
return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3186,7 +3258,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;
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
index 33bdb8e..899c231 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..6e14689 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;
+}
/*
*---------------------------------------------------------------------------
*
@@ -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 3 (or 4) byte UTF-8 sequences.
+ * 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 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,64 @@ 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] */
+ 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(int)));
+ wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ p = src;
+ endPtr = src + length;
+ optPtr = endPtr - 4;
+ while (p <= optPtr) {
+ p += TclUtfToUCS4(p, &ch);
+ *w++ = ch;
+ }
+ while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) {
+ p += TclUtfToUCS4(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] */
@@ -522,6 +710,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 +725,20 @@ 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(unsigned short)));
+ wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
- optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3) ;
+ optPtr = endPtr - 3;
while (p <= optPtr) {
- p += TclUtfToUniChar(p, &ch);
+ 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,61 @@ Tcl_NumUtfChars(
return i;
}
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_NumUtfChars
+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
+
/*
*---------------------------------------------------------------------------
*
@@ -763,7 +1009,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 +1019,6 @@ Tcl_UtfNext(
}
return src;
}
-#endif
left = totalBytes[UCHAR(*src)];
next = src + 1;
@@ -905,10 +1149,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 +1164,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 +1176,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;
+ }
+ TclUtfToUCS4(src, &i);
+ return i;
}
/*
@@ -951,7 +1205,9 @@ Tcl_UniCharAtIndex(
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in
- * the UTF-8 string.
+ * the UTF-8 string. If TCL_UTF_MAX < 4, characters > U+FFFF count as
+ * 2 positions, but then the pointer should never be placed between
+ * the two positions.
*
* Results:
* As above.
@@ -962,27 +1218,56 @@ Tcl_UniCharAtIndex(
*---------------------------------------------------------------------------
*/
+#if TCL_UTF_MAX < 4
+# undef Tcl_UtfToUniChar
+# define Tcl_UtfToUniChar Tcl_UtfToChar16
+#endif
+
const char *
-Tcl_UtfAtIndex(
+TclUtfAtIndex(
const char *src, /* The UTF-8 string. */
int index) /* The position of the desired character. */
{
- Tcl_UniChar ch = 0;
+ Tcl_UniChar ch = 0;
int len = 0;
while (index-- > 0) {
- len = TclUtfToUniChar(src, &ch);
+ len = (Tcl_UtfToUniChar)(src, &ch);
src += len;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
if ((ch >= 0xD800) && (len < 3)) {
/* Index points at character following high Surrogate */
- src += TclUtfToUniChar(src, &ch);
+ src += (Tcl_UtfToUniChar)(src, &ch);
}
#endif
return src;
}
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_UtfAtIndex
+const char *
+Tcl_UtfAtIndex(
+ const char *src, /* The UTF-8 string. */
+ int index) /* The position of the desired character. */
+{
+ unsigned short ch = 0;
+ int len = 0;
+
+ while (index-- > 0) {
+ len = Tcl_UtfToChar16(src, &ch);
+ src += len;
+ }
+ if ((ch >= 0xD800) && (len < 3)) {
+ /* Index points at character following high Surrogate */
+ src += Tcl_UtfToChar16(src, &ch);
+ }
+ return src;
+}
+
+
+#endif
+
/*
*---------------------------------------------------------------------------
*
@@ -992,7 +1277,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.
@@ -1069,7 +1354,7 @@ Tcl_UtfToUpper(
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
- upChar = UCS4ToUpper(ch);
+ upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -1077,11 +1362,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;
}
@@ -1122,7 +1407,7 @@ Tcl_UtfToLower(
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
- lowChar = TclUCS4ToLower(ch);
+ lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -1130,11 +1415,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;
}
@@ -1178,13 +1463,13 @@ Tcl_UtfToTitle(
if (*src) {
len = TclUtfToUCS4(src, &ch);
- titleChar = UCS4ToTitle(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;
}
@@ -1193,14 +1478,14 @@ Tcl_UtfToTitle(
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,7 +1581,7 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1347,7 +1632,7 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1366,6 +1651,52 @@ 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) {
+#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;
+ }
+ }
+ return UCHAR(*cs) - UCHAR(*ct);
+}
+
/*
*----------------------------------------------------------------------
@@ -1396,7 +1727,7 @@ TclUtfCasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX < 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1433,8 +1764,8 @@ TclUtfCasecmp(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToUpper(
+int
+Tcl_UniCharToUpper(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1447,13 +1778,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 +1796,7 @@ Tcl_UniCharToUpper(
*/
int
-TclUCS4ToLower(
+Tcl_UniCharToLower(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1487,13 +1811,6 @@ TclUCS4ToLower(
return ch & 0x1FFFFF;
}
-Tcl_UniChar
-Tcl_UniCharToLower(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) TclUCS4ToLower(ch);
-}
-
/*
*----------------------------------------------------------------------
*
@@ -1510,8 +1827,8 @@ Tcl_UniCharToLower(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToTitle(
+int
+Tcl_UniCharToTitle(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1533,14 +1850,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 +1898,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 +1930,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) && (TCL_UTF_MAX > 3)
+ /*
+ * 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 (TCL_UTF_MAX > 3) && !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) && (TCL_UTF_MAX > 3)
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
@@ -1608,21 +1977,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 +2009,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 (TCL_UTF_MAX > 3) && !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 +2075,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 +2101,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 +2127,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 +2138,6 @@ Tcl_UniCharIsControl(
}
return 0;
}
-#endif
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
@@ -1780,11 +2161,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 +2187,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 +2213,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 +2239,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 +2265,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 +2291,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 +2301,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 +2331,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 +2387,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 +2417,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 (TCL_UTF_MAX > 3) && !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 +2680,7 @@ Tcl_UniCharCaseMatch(
*/
if (p == '[') {
- Tcl_UniChar startChar, endChar;
+ unsigned short startChar, endChar;
uniPattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
@@ -2192,7 +2750,9 @@ Tcl_UniCharCaseMatch(
uniPattern++;
}
}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -2397,7 +2957,7 @@ TclUniCharMatch(
* 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
+ * Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Results:
@@ -2410,30 +2970,17 @@ TclUniCharMatch(
*---------------------------------------------------------------------------
*/
+#if TCL_UTF_MAX < 4
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;
+# undef Tcl_UtfToUniChar
+ return Tcl_UtfToUniChar(src, ucs4Ptr);
}
-#if TCL_UTF_MAX == 4
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
@@ -2441,62 +2988,27 @@ TclUniCharToUCS4(
* by the Tcl_UniChar string. */
{
if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
- *ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[01] & 0x3FF)) + 0x10000;
+ *ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[1] & 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);
+const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *src, const Tcl_UniChar *ptr) {
+ if (src <= ptr + 1) {
+ return ptr;
}
-#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;
+ if (((src[-1] & 0xFC00) == 0xDC00) && ((src[-2] & 0xFC00) == 0xD800)) {
+ return src - 2;
}
- return Tcl_UniCharToUtf(ch, buf);
+ return src - 1;
}
+
+
+#endif
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index ddcb254..7bd55e2 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,14 +106,13 @@ 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,
+ size_t 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,
+ size_t endValue, Tcl_WideInt *widePtr);
static int FindElement(Tcl_Interp *interp, const char *string,
int stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
@@ -121,16 +121,20 @@ static int FindElement(Tcl_Interp *interp, const char *string,
/*
* 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
@@ -395,7 +399,7 @@ TclMaxListLength(
{
int 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);
}
/*
@@ -798,9 +802,11 @@ TclCopyAndCollapse(
char c = *src;
if (c == '\\') {
+ char buf[4] = "";
int numRead;
- int backslashCount = TclParseBackslash(src, count, &numRead, dst);
+ int backslashCount = TclParseBackslash(src, count, &numRead, buf);
+ memcpy(dst, buf, backslashCount);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
@@ -845,6 +851,7 @@ TclCopyAndCollapse(
*----------------------------------------------------------------------
*/
+#undef Tcl_SplitList
int
Tcl_SplitList(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
@@ -867,7 +874,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);
@@ -890,7 +897,7 @@ Tcl_SplitList(
ckfree(argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "internal error in Tcl_SplitList", -1));
+ "internal error in Tcl_SplitList", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
@@ -938,9 +945,9 @@ int
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 +958,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
@@ -969,7 +976,7 @@ Tcl_ScanElement(
int
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
- int length, /* Number of bytes in src, or -1. */
+ int length, /* Number of bytes in src, or TCL_INDEX_NONE. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
@@ -988,7 +995,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,10 +1017,10 @@ 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. */
+ int length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
@@ -1026,7 +1033,7 @@ TclScanElement(
int 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 +1041,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.
*/
@@ -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? */
@@ -1323,7 +1330,7 @@ Tcl_ConvertElement(
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);
}
/*
@@ -1350,7 +1357,7 @@ Tcl_ConvertElement(
int
Tcl_ConvertCountedElement(
const char *src, /* Source information for list element. */
- int length, /* Number of bytes in src, or -1. */
+ int 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. */
{
@@ -1383,7 +1390,7 @@ Tcl_ConvertCountedElement(
int
TclConvertElement(
const char *src, /* Source information for list element. */
- int length, /* Number of bytes in src, or -1. */
+ int 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++;
@@ -1521,7 +1528,7 @@ TclConvertElement(
p++;
continue;
case '\0':
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
return p - 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 */
/*
*----------------------------------------------------------------------
@@ -1705,10 +1714,7 @@ TclTrimRight(
const char *q = trim;
int 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);
@@ -2018,7 +2024,7 @@ Tcl_ConcatObj(
if (TclListObjIsCanonical(objPtr)) {
continue;
}
- Tcl_GetStringFromObj(objPtr, &length);
+ TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
@@ -2027,7 +2033,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) {
@@ -2114,6 +2120,7 @@ Tcl_ConcatObj(
return resPtr;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -2132,6 +2139,7 @@ Tcl_ConcatObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_StringMatch
int
Tcl_StringMatch(
const char *str, /* String. */
@@ -2140,7 +2148,7 @@ Tcl_StringMatch(
{
return Tcl_StringCaseMatch(str, pattern, 0);
}
-
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
@@ -2214,7 +2222,7 @@ Tcl_StringCaseMatch(
} else {
TclUtfToUCS4(pattern, &ch2);
if (nocase) {
- ch2 = TclUCS4ToLower(ch2);
+ ch2 = Tcl_UniCharToLower(ch2);
}
}
@@ -2229,7 +2237,7 @@ Tcl_StringCaseMatch(
if (nocase) {
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
- if (ch2==ch1 || ch2==TclUCS4ToLower(ch1)) {
+ if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
@@ -2288,7 +2296,7 @@ Tcl_StringCaseMatch(
} else {
str += TclUtfToUCS4(str, &ch1);
if (nocase) {
- ch1 = TclUCS4ToLower(ch1);
+ ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
@@ -2302,7 +2310,7 @@ Tcl_StringCaseMatch(
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
if (nocase) {
- startChar = TclUCS4ToLower(startChar);
+ startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
@@ -2317,7 +2325,7 @@ Tcl_StringCaseMatch(
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
- endChar = TclUCS4ToLower(endChar);
+ endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
@@ -2366,7 +2374,7 @@ Tcl_StringCaseMatch(
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
if (nocase) {
- if (TclUCS4ToLower(ch1) != TclUCS4ToLower(ch2)) {
+ if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
@@ -2403,7 +2411,7 @@ TclByteArrayMatch(
/* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
@@ -2588,11 +2596,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 +2657,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,8 +2665,8 @@ 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. */
+ const char *bytes, /* String to append. If length is
+ * < 0 then this must be null-terminated. */
int length) /* Number of bytes from "bytes" to append. If
* < 0, then append all of bytes, up to null
* at end. */
@@ -2684,18 +2692,18 @@ Tcl_DStringAppend(
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
- int offset = -1;
+ int index = TCL_INDEX_NONE;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
- offset = bytes - dsPtr->string;
+ index = bytes - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
- if (offset >= 0) {
- bytes = dsPtr->string + offset;
+ if (index >= 0) {
+ bytes = dsPtr->string + index;
}
}
}
@@ -2727,7 +2735,7 @@ TclDStringAppendObj(
Tcl_Obj *objPtr)
{
int length;
- char *bytes = Tcl_GetStringFromObj(objPtr, &length);
+ char *bytes = TclGetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
@@ -2753,7 +2761,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.
*
*----------------------------------------------------------------------
@@ -2794,7 +2802,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;
}
@@ -2843,7 +2851,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;
}
@@ -2965,8 +2973,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 +3002,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 +3033,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 +3042,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 +3081,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 +3107,7 @@ Tcl_DStringGetResult(
*/
Tcl_Obj *
-TclDStringToObj(
+Tcl_DStringToObj(
Tcl_DString *dsPtr)
{
Tcl_Obj *result;
@@ -3204,9 +3220,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 +3236,7 @@ Tcl_PrintDouble(
* Handle NaN.
*/
- if (TclIsNaN(value)) {
+ if (isnan(value)) {
TclFormatNaN(value, dst);
return;
}
@@ -3231,7 +3245,7 @@ Tcl_PrintDouble(
* Handle infinities.
*/
- if (TclIsInfinite(value)) {
+ if (isinf(value)) {
/*
* Remember to copy the terminating NUL too.
*/
@@ -3249,7 +3263,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 +3300,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 +3392,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 +3426,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 +3442,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)*/
/*
*----------------------------------------------------------------------
@@ -3557,9 +3573,9 @@ int
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;
+ Tcl_WideUInt intVal;
int i = 0;
int numFormatted, j;
static const char digits[] = "0123456789";
@@ -3568,7 +3584,7 @@ TclFormatInt(
* 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,7 +3611,67 @@ 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 */
+ size_t endValue, /* The value to be stored at *widePtr if
+ * objPtr holds "end".
+ * NOTE: this value may be TCL_INDEX_NONE. */
+ Tcl_WideInt *widePtr) /* Location filled in with a wide integer
+ * representing an index. */
+{
+ int numType;
+ void *cd;
+ int code = 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;
+ 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)) ? WIDE_MIN : 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
@@ -3622,7 +3698,7 @@ TclFormatInt(
*/
int
-TclGetIntForIndex(
+Tcl_GetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
@@ -3631,124 +3707,44 @@ TclGetIntForIndex(
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
- * representing an index. */
+ * 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;
+ *indexPtr = (int) wide;
}
- 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;
- }
- 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.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Stores a valid string in the object's string rep.
- *
- * 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.
+ * GetEndOffsetFromObj --
*
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *----------------------------------------------------------------------
+ * Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
+ * convert it to an internal representation.
*
- * GetEndOffsetFromObj --
+ * The internal representation (wideValue) uses the following encoding:
*
- * 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
+ * WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
@@ -3761,118 +3757,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
+ size_t endValue, /* The value to be stored at "indexPtr" 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;
+ int 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 */
- 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 ((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);
+
+ 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;
+ } else if (offset == WIDE_MIN) {
+ *widePtr = -1;
+ } else if (endValue == (size_t)-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", NULL);
+ }
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -3887,7 +4004,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 +4013,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.
@@ -3938,47 +4055,32 @@ TclIndexEncode(
int 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;
}
@@ -4006,10 +4108,14 @@ TclIndexDecode(
int encoded, /* Value to decode */
int 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 +4177,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 +4260,7 @@ GetThreadHash(
static void
FreeThreadHash(
- ClientData clientData)
+ void *clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
@@ -4176,7 +4282,7 @@ FreeThreadHash(
static void
FreeProcessGlobalValue(
- ClientData clientData)
+ void *clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
@@ -4225,7 +4331,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) {
@@ -4418,11 +4525,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;
@@ -4693,7 +4799,7 @@ TclReToGlob(
invalidGlob:
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index b2e59b3..8ff43f0 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;
@@ -146,6 +145,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 +165,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 +207,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 +227,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 +248,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) : -1; \
+ } 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(
@@ -474,9 +516,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 +599,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;
+ int 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 +620,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 +632,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
@@ -615,33 +650,23 @@ TclObjLookupVarEx(
}
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;
+ int len;
+ const char *part1 = TclGetStringFromObj(part1Ptr, &len);
+
+ if ((len > 1) && (part1[len - 1] == ')')) {
+ const char *part2 = strchr(part1, '(');
- len2 = -1;
- for (i = 0; i < len1; i++) {
- if (*(part1 + i) == '(') {
+ if (part2) {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
@@ -652,49 +677,13 @@ TclObjLookupVarEx(
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,8 +694,6 @@ TclObjLookupVarEx(
* the cached types if possible.
*/
- TclFreeIntRep(part1Ptr);
-
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
@@ -715,9 +702,6 @@ TclObjLookupVarEx(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(part1Ptr), NULL);
}
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
return NULL;
}
@@ -729,28 +713,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 +768,6 @@ TclObjLookupVarEx(
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
createPart1, createPart2, varPtr, -1);
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
}
return varPtr;
}
@@ -935,38 +934,41 @@ 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;
@@ -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
@@ -1106,16 +1106,7 @@ TclLookupArrayElement(
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,
@@ -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)) {
@@ -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
@@ -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) {
/*
@@ -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 */
/*
*----------------------------------------------------------------------
@@ -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,7 +2948,7 @@ 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. */
@@ -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,310 @@ 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, numVars;
+
+ /*
+ * array for {k v} a body
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse arguments.
+ */
+
+ if (TclListObjLengthM(interp, objv[1], &numVars) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (numVars != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
+ 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.
+ */
+
+ varListObj = TclListObjCopy(NULL, objv[1]);
+ 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, 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", NULL);
+ varPtr->flags |= TCL_LEAVE_ERR_MSG;
+ result = done;
+ }
+ goto arrayfordone;
+ }
+
+ TclListObjGetElementsM(NULL, varListObj, &varc, &varv);
+ if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto arrayfordone;
+ }
+ if (valueObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj,
+ 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 +3393,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 +3419,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 +3488,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 +3566,7 @@ ArrayAnyMoreCmd(
static int
ArrayNextElementCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3207,16 +3646,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 +3681,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 +3706,7 @@ ArrayDoneSearchCmd(
static int
ArrayExistsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3327,7 +3746,7 @@ ArrayExistsCmd(
static int
ArrayGetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3419,7 +3838,7 @@ ArrayGetCmd(
*/
TclNewObj(tmpResObj);
- result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr);
+ result = TclListObjGetElementsM(interp, nameLstObj, &count, &nameObjPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
@@ -3486,7 +3905,7 @@ ArrayGetCmd(
static int
ArrayNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3653,7 +4072,7 @@ TclFindArrayPtrElements(
static int
ArraySetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3692,7 +4111,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;
@@ -3742,8 +4161,7 @@ ArraySetCmd(
int elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
- result = TclListObjGetElements(interp, arrayElemObj,
- &elemLen, &elemPtrs);
+ result = TclListObjLengthM(interp, arrayElemObj, &elemLen);
if (result != TCL_OK) {
return result;
}
@@ -3756,6 +4174,11 @@ ArraySetCmd(
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
@@ -3805,9 +4228,7 @@ ArraySetCmd(
return TCL_ERROR;
}
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
return TCL_OK;
}
@@ -3830,7 +4251,7 @@ ArraySetCmd(
static int
ArraySizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3865,7 +4286,7 @@ ArraySizeCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
return TCL_OK;
}
@@ -3889,7 +4310,7 @@ ArraySizeCmd(
static int
ArrayStatsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3943,7 +4364,7 @@ ArrayStatsCmd(
static int
ArrayUnsetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -4083,8 +4504,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},
@@ -4394,6 +4817,7 @@ TclPtrObjMakeUpvarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UpVar
int
Tcl_UpVar(
@@ -4427,6 +4851,7 @@ Tcl_UpVar(
Tcl_DecrRefCount(localNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -4564,7 +4989,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 +5093,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. */
@@ -4801,7 +5226,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. */
@@ -4881,75 +5306,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 +5316,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 +5331,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, NULL);
return NULL;
}
@@ -5072,6 +5402,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;
@@ -5364,8 +5695,7 @@ DeleteArray(
TclClearVarNamespaceVar(elPtr);
}
- VarHashDeleteTable(varPtr->value.tablePtr);
- ckfree(varPtr->value.tablePtr);
+ DeleteArrayVar(varPtr);
}
/*
@@ -5443,28 +5773,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 +5785,15 @@ static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+
+ LocalGetInternalRep(objPtr, index, namePtr);
+ index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5490,17 +5801,14 @@ DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ int 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 +5824,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 +5841,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;
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
- if (arrayPtr != NULL) {
- Tcl_IncrRefCount(arrayPtr);
- elemLen = strlen(elem);
- elemCopy = (char *)ckalloc(elemLen + 1);
- memcpy(elemCopy, elem, elemLen);
- *(elemCopy + elemLen) = '\0';
- elem = elemCopy;
- }
+ ParsedGetInternalRep(srcPtr, parsed, arrayPtr, elem);
- 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");
- }
-
- part1 = TclGetStringFromObj(arrayPtr, &len1);
- len2 = strlen(part2);
-
- 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);
}
/*
@@ -5773,7 +6038,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 +6229,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 +6322,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. */
@@ -6207,25 +6472,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 +6537,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;
@@ -6319,6 +6609,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", 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), 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", 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..9f6d8aa
--- /dev/null
+++ b/generic/tclZipfs.c
@@ -0,0 +1,6015 @@
+/*
+ * 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.
+ */
+
+#include "tclInt.h"
+#include "tclFileSystem.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", 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, 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_VOLUME_LEN 9
+#define ZIPFS_APP_MOUNT "//zipfs:/app"
+#define ZIPFS_ZIP_MOUNT "//zipfs:/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 DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024)
+
+/*
+ * Windows drive letters.
+ */
+
+#ifdef _WIN32
+static const char drvletters[] =
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+#endif /* _WIN32 */
+
+/*
+ * 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 */
+ 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 */
+ size_t 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.
+ * ZIP_ATTR_
+ */
+
+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 */
+ int numCompressedBytes; /* Compressed size of the virtual file */
+ int compressMethod; /* Compress method */
+ int isDirectory; /* Set to 1 if directory, or -1 if root */
+ int depth; /* Number of slashes in path. */
+ int crc32; /* CRC-32 */
+ int timestamp; /* Modification time */
+ int isEncrypted; /* True if data is encrypted */
+ 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.
+ */
+
+typedef struct ZipChannel {
+ ZipFile *zipFilePtr; /* The ZIP file holding this channel */
+ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
+ size_t maxWrite; /* Maximum size for write */
+ size_t numBytes; /* Number of bytes of uncompressed data */
+ size_t numRead; /* Position of next byte to be read from the
+ * channel */
+ unsigned char *ubuf; /* Pointer to the uncompressed data */
+ 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 isWriting; /* True if open for writing */
+ unsigned long keys[3]; /* Key for decryption */
+} ZipChannel;
+
+/*
+ * 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. */
+ Tcl_Encoding utf8; /* The UTF-8 encoding that we prefer to use
+ * for the strings (especially filenames)
+ * embedded in a ZIP. Other encodings are used
+ * dynamically. */
+ 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, 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 inline 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 inline int ListMountPoints(Tcl_Interp *interp);
+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);
+#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 ZipfsExitHandler(ClientData clientData);
+static void ZipfsMountExitHandler(ClientData clientData);
+static void ZipfsSetup(void);
+static void ZipfsFinalize(void);
+static int ZipChannelClose(void *instanceData,
+ Tcl_Interp *interp, int flags);
+static Tcl_DriverGetHandleProc ZipChannelGetFile;
+static int ZipChannelRead(void *instanceData, char *buf,
+ int toRead, int *errloc);
+#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)
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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)
+{
+ Tcl_Encoding encoding;
+ const char *src;
+ char *dst;
+ int dstLen, srcLen = inputLength, flags;
+ Tcl_EncodingState state;
+
+ Tcl_DStringInit(dstPtr);
+ 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_STOPONERROR; /* Special flag! */
+
+ while (1) {
+ int srcRead, dstWrote;
+ int result = Tcl_ExternalToUtf(NULL, ZipFS.utf8, 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * CanonicalPath --
+ *
+ * This function computes the canonical path from a directory and file
+ * name components into the specified Tcl_DString.
+ *
+ * Results:
+ * Returns the pointer to the canonical path contained in the specified
+ * Tcl_DString.
+ *
+ * Side effects:
+ * Modifies the specified Tcl_DString.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static char *
+CanonicalPath(
+ const char *root,
+ const char *tail,
+ Tcl_DString *dsPtr,
+ int inZipfs)
+{
+ char *path;
+ int i, j, c, isUNC = 0, isVfs = 0, n = 0;
+ int haveZipfsPath = 1;
+
+#ifdef _WIN32
+ if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') {
+ tail += 2;
+ haveZipfsPath = 0;
+ }
+ /* UNC style path */
+ if (tail[0] == '\\') {
+ root = "";
+ ++tail;
+ haveZipfsPath = 0;
+ }
+ if (tail[0] == '\\') {
+ root = "/";
+ ++tail;
+ haveZipfsPath = 0;
+ }
+#endif /* _WIN32 */
+
+ if (haveZipfsPath) {
+ /* UNC style path */
+ if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) {
+ isVfs = 1;
+ } else if (tail &&
+ strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) {
+ isVfs = 2;
+ }
+ if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) {
+ isUNC = 1;
+ }
+ }
+
+ if (isVfs != 2) {
+ if (tail[0] == '/') {
+ if (isVfs != 1) {
+ root = "";
+ }
+ ++tail;
+ isUNC = 0;
+ }
+ if (tail[0] == '/') {
+ if (isVfs != 1) {
+ root = "/";
+ }
+ ++tail;
+ isUNC = 1;
+ }
+ }
+ i = strlen(root);
+ j = strlen(tail);
+
+ switch (isVfs) {
+ case 1:
+ if (i > ZIPFS_VOLUME_LEN) {
+ Tcl_DStringSetLength(dsPtr, i + j + 1);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ path[i++] = '/';
+ memcpy(path + i, tail, j);
+ } else {
+ Tcl_DStringSetLength(dsPtr, i + j);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ memcpy(path + i, tail, j);
+ }
+ break;
+ case 2:
+ Tcl_DStringSetLength(dsPtr, j);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, tail, j);
+ break;
+ default:
+ if (inZipfs) {
+ Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN);
+ memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j);
+ } else {
+ Tcl_DStringSetLength(dsPtr, i + j + 1);
+ path = Tcl_DStringValue(dsPtr);
+ memcpy(path, root, i);
+ path[i++] = '/';
+ memcpy(path + i, tail, j);
+ }
+ break;
+ }
+
+#ifdef _WIN32
+ for (i = 0; path[i] != '\0'; i++) {
+ if (path[i] == '\\') {
+ path[i] = '/';
+ }
+ }
+#endif /* _WIN32 */
+
+ if (inZipfs) {
+ n = ZIPFS_VOLUME_LEN;
+ } else {
+ n = 0;
+ }
+
+ for (i = j = n; (c = path[i]) != '\0'; i++) {
+ if (c == '/') {
+ int c2 = path[i + 1];
+
+ if (c2 == '\0' || c2 == '/') {
+ continue;
+ }
+ if (c2 == '.') {
+ int c3 = path[i + 2];
+
+ if ((c3 == '/') || (c3 == '\0')) {
+ i++;
+ continue;
+ }
+ if ((c3 == '.')
+ && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) {
+ i += 2;
+ while ((j > 0) && (path[j - 1] != '/')) {
+ j--;
+ }
+ if (j > isUNC) {
+ --j;
+ while ((j > 1 + isUNC) && (path[j - 2] == '/')) {
+ j--;
+ }
+ }
+ continue;
+ }
+ }
+ }
+ path[j++] = c;
+ }
+ if (j == 0) {
+ path[j++] = '/';
+ }
+ path[j] = 0;
+ Tcl_DStringSetLength(dsPtr, j);
+ 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFindTOC(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i, minoff;
+ const unsigned char *p, *q;
+ 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.
+ */
+
+ p = zf->data + zf->length - ZIP_CENTRAL_END_LEN;
+ while (p >= start) {
+ if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) {
+ if (ZipReadInt(start, end, p) == ZIP_CENTRAL_END_SIG) {
+ break;
+ }
+ p -= ZIP_SIG_LEN;
+ } else {
+ --p;
+ }
+ }
+ if (p < 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, "wrong end signature");
+ ZIPFS_ERROR_CODE(interp, "END_SIG");
+ goto error;
+ }
+
+ /*
+ * How many files in the archive? If that's bogus, we're done here.
+ */
+
+ zf->numFiles = ZipReadShort(start, end, p + 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;
+ }
+
+ /*
+ * Where does the central directory start?
+ */
+
+ q = zf->data + ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSTART_OFFS);
+ p -= ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSIZE_OFFS);
+ zf->baseOffset = zf->passOffset = (p>q) ? p - q : 0;
+ zf->directoryOffset = q - zf->data + zf->baseOffset;
+ if ((p < q) || (p < zf->data) || (p > zf->data + zf->length)
+ || (q < zf->data) || (q > zf->data + zf->length)) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "archive directory not found");
+ ZIPFS_ERROR_CODE(interp, "NO_DIR");
+ goto error;
+ }
+
+ /*
+ * Read the central directory.
+ */
+
+ q = p;
+ minoff = zf->length;
+ for (i = 0; i < zf->numFiles; i++) {
+ int pathlen, comlen, extra;
+ size_t localhdr_off = zf->length;
+
+ if (q + ZIP_CENTRAL_HEADER_LEN > end) {
+ ZIPFS_ERROR(interp, "wrong header length");
+ ZIPFS_ERROR_CODE(interp, "HDR_LEN");
+ goto error;
+ }
+ if (ZipReadInt(start, end, q) != ZIP_CENTRAL_HEADER_SIG) {
+ ZIPFS_ERROR(interp, "wrong header signature");
+ ZIPFS_ERROR_CODE(interp, "HDR_SIG");
+ goto error;
+ }
+ 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);
+ localhdr_off = ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS);
+ if (ZipReadInt(start, end, zf->data + zf->baseOffset + localhdr_off) != 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;
+ }
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+
+ zf->passOffset = minoff + zf->baseOffset;
+
+ /*
+ * If there's also an encoded password, extract that too (but don't decode
+ * yet).
+ */
+
+ 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;
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * 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;
+ }
+ if ((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;
+ }
+ 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.
+ */
+
+# ifdef _WIN64
+ readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0;
+# else /* !_WIN64 */
+ zf->length = GetFileSize(hFile, 0);
+ readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
+# endif /* _WIN64 */
+ if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Map the file.
+ */
+
+ zf->mountHandle = CreateFileMappingW(hFile, 0, PAGE_READONLY, 0,
+ zf->length, 0);
+ if (zf->mountHandle == INVALID_HANDLE_VALUE) {
+ 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) {
+ 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 || zf->length < ZIP_CENTRAL_END_LEN) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ 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.
+ *
+ * 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. */
+ 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, dsm, fpBuf;
+ unsigned char *q;
+
+ /*
+ * Basic verification of the password for sanity.
+ */
+
+ pwlen = 0;
+ if (passwd) {
+ pwlen = strlen(passwd);
+ if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) {
+ 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();
+
+ /*
+ * Mount point sometimes is a relative or otherwise denormalized path.
+ * But an absolute name is needed as mount point here.
+ */
+
+ Tcl_DStringInit(&ds);
+ Tcl_DStringInit(&dsm);
+ if (strcmp(mountPoint, "/") == 0) {
+ mountPoint = "";
+ } else {
+ mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
+ }
+ 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);
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ Unlock();
+
+ /*
+ * Convert to a real archive descriptor.
+ */
+
+ zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+ Tcl_CreateExitHandler(ZipfsMountExitHandler, zf);
+ 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';
+ }
+ if (mountPoint[0] != '\0') {
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew);
+ if (isNew) {
+ z = AllocateZipEntry();
+ Tcl_SetHashValue(hPtr, z);
+
+ z->depth = CountSlashes(mountPoint);
+ 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);
+ 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);
+ 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 = CanonicalPath(mountPoint, path, &fpBuf, 1);
+ z = AllocateZipEntry();
+ z->depth = CountSlashes(fullpath);
+ z->zipFilePtr = zf;
+ z->isDirectory = isdir;
+ z->isEncrypted =
+ (ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1)
+ && (nbcompr > 12);
+ 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 == 1)) {
+ 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 > 1)) {
+ 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);
+ 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 == 1)) {
+ zd->tnext = zf->topEnts;
+ zf->topEnts = zd;
+ }
+ }
+ }
+ nextent:
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ Tcl_DStringFree(&fpBuf);
+ Tcl_DStringFree(&ds);
+ Tcl_FSMountsChanged(NULL);
+ Unlock();
+ 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.utf8 = Tcl_GetEncoding(NULL, "utf-8");
+ ZipFS.initialized = 1;
+ Tcl_CreateExitHandler(ZipfsExitHandler, NULL);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 inline 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);
+ }
+
+ resultList = Tcl_NewObj();
+ 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 inline 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 *mountPoint, /* Mount point path. */
+ const char *zipname, /* Path to ZIP file to mount; should be
+ * normalized. */
+ const char *passwd) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZipFile *zf;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (!mountPoint) {
+ int ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ /*
+ * Mount point but no file, so describe what is mounted at that mount
+ * point.
+ */
+
+ if (!zipname) {
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+ Unlock();
+
+ /*
+ * Have both a mount point and a file (name) to mount there.
+ */
+
+ if (passwd && IsPasswordValid(interp, passwd, strlen(passwd)) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ zf = AllocateZipFile(interp, strlen(mountPoint));
+ if (!zf) {
+ return TCL_ERROR;
+ }
+ if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_MountBuffer --
+ *
+ * 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_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ unsigned char *data,
+ size_t datalen,
+ int copy)
+{
+ ZipFile *zf;
+ int result;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (!mountPoint) {
+ int ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ /*
+ * Mount point but no data, so describe what is mounted at that mount
+ * point.
+ */
+
+ if (!data) {
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+ Unlock();
+
+ /*
+ * Have both a mount point and data to mount there.
+ */
+
+ zf = AllocateZipFile(interp, strlen(mountPoint));
+ if (!zf) {
+ return TCL_ERROR;
+ }
+ zf->isMemBuffer = 1;
+ zf->length = datalen;
+ if (copy) {
+ zf->data = (unsigned char *) attemptckalloc(datalen);
+ if (!zf->data) {
+ ZIPFS_MEM_ERROR(interp);
+ return TCL_ERROR;
+ }
+ memcpy(zf->data, data, datalen);
+ zf->ptrToFree = zf->data;
+ } else {
+ zf->data = data;
+ zf->ptrToFree = NULL;
+ }
+ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
+ "Memory Buffer");
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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;
+ ZipEntry *z, *znext;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString dsm;
+ int ret = TCL_OK, unmounted = 0;
+
+ 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.
+ */
+
+ Tcl_DStringInit(&dsm);
+ mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
+
+ 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.
+ */
+
+ 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);
+ }
+ ZipFSCloseArchive(interp, zf);
+ Tcl_DeleteExitHandler(ZipfsMountExitHandler, zf);
+ ckfree(zf);
+ unmounted = 1;
+
+ done:
+ Unlock();
+ 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *mountPoint = NULL, *zipFile = NULL, *password = NULL;
+ Tcl_Obj *zipFileObj = NULL;
+ int result;
+
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?mountpoint? ?zipfile? ?password?");
+ return TCL_ERROR;
+ }
+ if (objc > 1) {
+ mountPoint = Tcl_GetString(objv[1]);
+ }
+ if (objc > 2) {
+ zipFileObj = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ if (!zipFileObj) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "could not normalize zip filename", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(zipFileObj);
+ zipFile = Tcl_GetString(zipFileObj);
+ }
+ if (objc > 3) {
+ password = Tcl_GetString(objv[3]);
+ }
+
+ result = TclZipfs_Mount(interp, mountPoint, zipFile, password);
+ if (zipFileObj != NULL) {
+ Tcl_DecrRefCount(zipFileObj);
+ }
+ 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *mountPoint; /* Mount point path. */
+ unsigned char *data;
+ int length;
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
+ return TCL_ERROR;
+ }
+ if (objc < 2) {
+ int ret;
+
+ ReadLock();
+ ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ mountPoint = Tcl_GetString(objv[1]);
+ if (objc < 3) {
+ ReadLock();
+ DescribeMounted(interp, mountPoint);
+ Unlock();
+ return TCL_OK;
+ }
+
+ data = TclGetBytesFromObj(interp, objv[2], &length);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
+ return TclZipfs_MountBuffer(interp, mountPoint, data, length, 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
+{
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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(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, "zipfile");
+ 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int len, i = 0;
+ const char *pw;
+ Tcl_Obj *passObj;
+ 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, (int *)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", -1, 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(ZipFS.utf8, 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[24];
+
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ if (RandomChar(interp, i, &ch) != TCL_OK) {
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp));
+ }
+ Tcl_ResetResult(interp);
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + 12], 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, 12);
+ memset(kvbuf, 0, 24);
+ if (len != 12) {
+ goto writeErrorWithChannelOpen;
+ }
+ memcpy(keys0, keys, sizeof(keys0));
+ nbytecompr += 12;
+ }
+
+ /*
+ * 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 ? 12 : 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. */
+ int slen) /* The length of the prefix; must be 0 if no
+ * stripping need be done. */
+{
+ const char *name;
+ int 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(ZipFS.utf8, z->name, -1, &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;
+ int 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(ClientData),
+ 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(ClientData),
+ 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(ClientData),
+ 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(ClientData),
+ 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *mntpoint = NULL;
+ char *filename = NULL;
+ char *result;
+ Tcl_DString dPath;
+
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?");
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&dPath);
+ if (objc == 2) {
+ filename = Tcl_GetString(objv[1]);
+ result = CanonicalPath("", filename, &dPath, 1);
+ } else if (objc == 3) {
+ mntpoint = Tcl_GetString(objv[1]);
+ filename = Tcl_GetString(objv[2]);
+ result = CanonicalPath(mntpoint, filename, &dPath, 1);
+ } else {
+ int zipfs = 0;
+
+ if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) {
+ return TCL_ERROR;
+ }
+ mntpoint = Tcl_GetString(objv[1]);
+ filename = Tcl_GetString(objv[2]);
+ result = CanonicalPath(mntpoint, filename, &dPath, zipfs);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+ 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *filename;
+ int exists;
+ Tcl_DString ds;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Prepend ZIPFS_VOLUME to filename, eliding the final /
+ */
+
+ filename = Tcl_GetString(objv[1]);
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1);
+ Tcl_DStringAppend(&ds, filename, -1);
+ filename = Tcl_DStringValue(&ds);
+
+ ReadLock();
+ exists = ZipFSLookup(filename) != NULL;
+ 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(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ char *filename;
+ ZipEntry *z;
+
+ 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));
+ }
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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(ClientData),
+ 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.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+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 Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+
+ /*
+ * 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 Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+
+ /*
+ * 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 Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#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 Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#else
+ if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#endif /* _WIN32 */
+#endif /* !defined(STATIC_BUILD) */
+
+ /*
+ * If anything set the cache (but subsequently failed) go with that
+ * anyway.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ 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(ClientData),
+ 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->iscompr && info->ubuf) {
+ ckfree(info->ubuf);
+ info->ubuf = NULL;
+ }
+ if (info->isEncrypted) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ if (info->isWriting) {
+ ZipEntry *z = info->zipEntryPtr;
+ unsigned char *newdata = (unsigned char *)
+ attemptckrealloc(info->ubuf, info->numRead);
+
+ if (newdata) {
+ if (z->data) {
+ ckfree(z->data);
+ }
+ z->data = newdata;
+ z->numBytes = z->numCompressedBytes = info->numBytes;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->timestamp = time(NULL);
+ z->isDirectory = 0;
+ z->isEncrypted = 0;
+ z->offset = 0;
+ z->crc32 = 0;
+ } else {
+ ckfree(info->ubuf);
+ }
+ }
+ WriteLock();
+ info->zipFilePtr->numOpen--;
+ Unlock();
+ 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;
+ unsigned long 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->numRead + toRead;
+ if (nextpos > info->zipFilePtr->baseOffset) {
+ toRead = info->zipFilePtr->baseOffset - info->numRead;
+ nextpos = info->zipFilePtr->baseOffset;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ memcpy(buf, info->zipFilePtr->data, toRead);
+ info->numRead = nextpos;
+ *errloc = 0;
+ return toRead;
+ }
+ if (info->isDirectory) {
+ *errloc = EISDIR;
+ return -1;
+ }
+ nextpos = info->numRead + toRead;
+ if (nextpos > info->numBytes) {
+ toRead = info->numBytes - info->numRead;
+ nextpos = info->numBytes;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ if (info->isEncrypted) {
+ int i;
+
+ for (i = 0; i < toRead; i++) {
+ int ch = info->ubuf[i + info->numRead];
+
+ buf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ memcpy(buf, info->ubuf + info->numRead, toRead);
+ }
+ info->numRead = 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 (!info->isWriting) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ nextpos = info->numRead + toWrite;
+ if (nextpos > info->maxWrite) {
+ toWrite = info->maxWrite - info->numRead;
+ nextpos = info->maxWrite;
+ }
+ if (toWrite == 0) {
+ return 0;
+ }
+ memcpy(info->ubuf + info->numRead, buf, toWrite);
+ info->numRead = nextpos;
+ if (info->numRead > info->numBytes) {
+ info->numBytes = info->numRead;
+ }
+ *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;
+ size_t end;
+
+ if (!info->isWriting && (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->numRead;
+ break;
+ case SEEK_END:
+ offset += end;
+ break;
+ case SEEK_SET:
+ break;
+ default:
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (offset < 0) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (info->isWriting) {
+ if ((size_t) offset > info->maxWrite) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if ((size_t) offset > info->numBytes) {
+ info->numBytes = offset;
+ }
+ } else if ((size_t) offset > end) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ info->numRead = (size_t) offset;
+ return info->numRead;
+}
+
+#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(ClientData),
+ 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(ClientData),
+ TCL_UNUSED(int) /*direction*/,
+ TCL_UNUSED(ClientData *) /*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 wr, /* True if we're opening in write mode. */
+ int trunc) /* True if we're opening in truncate mode. */
+{
+ ZipEntry *z;
+ ZipChannel *info;
+ int flags = 0;
+ char cname[128];
+
+ /*
+ * Is the file there?
+ */
+
+ WriteLock();
+ z = ZipFSLookup(filename);
+ if (!z) {
+ Tcl_SetErrno(ENOENT);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file not found \"%s\": %s", filename,
+ Tcl_PosixError(interp)));
+ }
+ 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 (!trunc) {
+ flags |= TCL_READABLE;
+ if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) {
+ ZIPFS_ERROR(interp, "decryption failed");
+ ZIPFS_ERROR_CODE(interp, "DECRYPT");
+ goto error;
+ } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) {
+ ZIPFS_ERROR(interp, "file too large");
+ ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
+ goto error;
+ }
+ } else {
+ flags = TCL_WRITABLE;
+ }
+
+ info = AllocateZipChannel(interp);
+ if (!info) {
+ goto error;
+ }
+ info->zipFilePtr = z->zipFilePtr;
+ info->zipEntryPtr = z;
+ if (wr) {
+ /*
+ * Set up a writable channel.
+ */
+
+ flags |= TCL_WRITABLE;
+ if (InitWritableChannel(interp, info, z, trunc) == TCL_ERROR) {
+ ckfree(info);
+ goto error;
+ }
+ } else if (z->data) {
+ /*
+ * Set up a readable channel for direct data.
+ */
+
+ flags |= TCL_READABLE;
+ info->numBytes = z->numBytes;
+ info->ubuf = z->data;
+ } else {
+ /*
+ * Set up a readable channel.
+ */
+
+ flags |= TCL_READABLE;
+ if (InitReadableChannel(interp, info, z) == TCL_ERROR) {
+ 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 trunc) /* Whether to truncate the data. */
+{
+ int i, ch;
+ unsigned char *cbuf = NULL;
+
+ /*
+ * Set up a writable channel.
+ */
+
+ info->isWriting = 1;
+ info->maxWrite = ZipFS.wrmax;
+
+ info->ubuf = (unsigned char *) attemptckalloc(info->maxWrite);
+ if (!info->ubuf) {
+ goto memoryError;
+ }
+ memset(info->ubuf, 0, info->maxWrite);
+
+ if (trunc) {
+ /*
+ * Truncate; nothing there.
+ */
+
+ info->numBytes = 0;
+ } else if (z->data) {
+ /*
+ * Already got uncompressed data.
+ */
+
+ unsigned int j = z->numBytes;
+
+ if (j > info->maxWrite) {
+ j = info->maxWrite;
+ }
+ memcpy(info->ubuf, z->data, j);
+ info->numBytes = j;
+ } else {
+ /*
+ * Need to uncompress the existing data.
+ */
+
+ unsigned char *zbuf = z->zipFilePtr->data + z->offset;
+
+ if (z->isEncrypted) {
+ 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, info->keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ for (i = 0; i < 12; i++) {
+ ch = info->ubuf[i];
+ zdecode(info->keys, crc32tab, ch);
+ }
+ zbuf += i;
+ }
+
+ 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;
+
+ stream.avail_in -= 12;
+ cbuf = (unsigned char *) attemptckalloc(stream.avail_in);
+ if (!cbuf) {
+ goto memoryError;
+ }
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = info->ubuf[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->maxWrite;
+ 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))) {
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ return TCL_OK;
+ }
+ goto corruptionError;
+ } else if (z->isEncrypted) {
+ /*
+ * Need to decrypt some otherwise-simple stored data.
+ */
+
+ for (i = 0; i < z->numBytes - 12; i++) {
+ ch = zbuf[i];
+ info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ /*
+ * Simple stored data. Copy into our working buffer.
+ */
+
+ memcpy(info->ubuf, zbuf, z->numBytes);
+ }
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ return TCL_OK;
+
+ memoryError:
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ZIPFS_MEM_ERROR(interp);
+ return TCL_ERROR;
+
+ corruptionError:
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ZIPFS_ERROR(interp, "decompression error");
+ ZIPFS_ERROR_CODE(interp, "CORRUPT");
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * InitReadableChannel --
+ *
+ * Assistant for ZipChannelOpen() that sets up a readable 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
+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 i, ch;
+
+ info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
+ info->ubuf = z->zipFilePtr->data + z->offset;
+ info->isDirectory = z->isDirectory;
+ info->isEncrypted = z->isEncrypted;
+ info->numBytes = z->numBytes;
+
+ if (info->isEncrypted) {
+ 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, info->keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ for (i = 0; i < 12; i++) {
+ ch = info->ubuf[i];
+ zdecode(info->keys, crc32tab, ch);
+ }
+ info->ubuf += i;
+ }
+
+ if (info->iscompr) {
+ z_stream stream;
+ int err;
+ unsigned int j;
+
+ /*
+ * Data to decode is compressed, and possibly encrpyted too.
+ */
+
+ 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) {
+ stream.avail_in -= 12;
+ ubuf = (unsigned char *) attemptckalloc(stream.avail_in);
+ if (!ubuf) {
+ info->ubuf = NULL;
+ 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;
+ }
+ stream.next_out = info->ubuf = (unsigned char *)
+ attemptckalloc(info->numBytes);
+ 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;
+ }
+
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ return TCL_OK;
+ } 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.
+ */
+
+ len = z->numCompressedBytes - 12;
+ 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->ubuf = ubuf;
+ info->isEncrypted = 0;
+ }
+ return TCL_OK;
+
+ corruptionError:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ZIPFS_ERROR(interp, "decompression error");
+ ZIPFS_ERROR_CODE(interp, "CORRUPT");
+ return TCL_ERROR;
+
+ memoryError:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ ZIPFS_MEM_ERROR(interp);
+ 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 = -1;
+
+ 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;
+ }
+ 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)
+{
+ ZipEntry *z;
+
+ if (mode & 3) {
+ return -1;
+ }
+ ReadLock();
+ z = ZipFSLookup(path);
+ Unlock();
+ return (z ? 0 : -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 */)
+{
+ int trunc = (mode & O_TRUNC) != 0;
+ int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return NULL;
+ }
+
+ /*
+ * Check for unsupported modes.
+ */
+
+ if ((mode & O_APPEND) || ((ZipFS.wrmax <= 0) && wr)) {
+ Tcl_SetErrno(EACCES);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write access not supported: %s",
+ Tcl_PosixError(interp)));
+ }
+ return NULL;
+ }
+
+ return ZipChannelOpen(interp, Tcl_GetString(pathPtr), wr, trunc);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len;
+ char *pat, *prefix, *path;
+ Tcl_DString dsPref, *prefixBuf = NULL;
+
+ 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;
+ }
+
+ /*
+ * Can we skip the complexity of actual globbing? Without a pattern, yes;
+ * it's a directory existence test.
+ */
+
+ if (!pattern || (pattern[0] == '\0')) {
+ ZipEntry *z = ZipFSLookup(path);
+
+ if (z && ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
+ || (dirOnly && z->isDirectory))) {
+ AppendWithPrefix(result, prefixBuf, z->name, -1);
+ }
+ goto end;
+ }
+
+ /*
+ * 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);
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
+ || (!dirOnly && z->isDirectory))) {
+ continue;
+ }
+ if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
+ AppendWithPrefix(result, prefixBuf, z->name + strip, -1);
+ }
+ }
+ 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, normLength;
+ const char *path = TclGetStringFromObj(normPathPtr, &normLength);
+ size_t 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.
+ */
+
+ for (z = zf->topEnts; z; z = z->tnext) {
+ size_t 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(ClientData *))
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ int ret = -1, len;
+ char *path;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ path = TclGetStringFromObj(pathPtr, &len);
+ if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) {
+ return -1;
+ }
+
+ ReadLock();
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
+ if (hPtr) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ ZipEntry *z;
+
+ for (z = zf->topEnts; z != NULL; z = z->tnext) {
+ size_t lenz = strlen(z->name);
+
+ if (((size_t) len >= lenz) &&
+ (strncmp(path, z->name, lenz) == 0)) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+ }
+ } else if (((size_t) len >= zf->mountPointLen) &&
+ (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) {
+ ret = TCL_OK;
+ break;
+ }
+ }
+
+ endloop:
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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)
+{
+ int len, 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) {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_POSIX_ERROR(interp, "file not found");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ switch (index) {
+ case ZIP_ATTR_UNCOMPSIZE:
+ TclNewIntObj(*objPtrRef, z->numBytes);
+ break;
+ case ZIP_ATTR_COMPSIZE:
+ TclNewIntObj(*objPtrRef, z->numCompressedBytes);
+ break;
+ case ZIP_ATTR_OFFSET:
+ TclNewIntObj(*objPtrRef, z->offset);
+ break;
+ case ZIP_ATTR_MOUNT:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
+ z->zipFilePtr->mountPointLen);
+ break;
+ case ZIP_ATTR_ARCHIVE:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1);
+ break;
+ case ZIP_ATTR_PERMISSIONS:
+ *objPtrRef = Tcl_NewStringObj("0o555", -1);
+ break;
+ case ZIP_ATTR_CRC:
+ TclNewIntObj(*objPtrRef, z->crc32);
+ 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, -1, 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, ZIPFS_ZIP_MOUNT, archive, 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
+
+static void
+ZipfsExitHandler(
+ TCL_UNUSED(ClientData)
+)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ if (ZipFS.initialized != -1) {
+ hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ if (hPtr == NULL) {
+ ZipfsFinalize();
+ } else {
+ /* ZipFS.fallbackEntryEncoding was already freed by
+ * ZipfsMountExitHandler
+ */
+ }
+ }
+}
+
+static void
+ZipfsFinalize(void) {
+ Tcl_FSUnregister(&zipfsFilesystem);
+ Tcl_DeleteHashTable(&ZipFS.fileHash);
+ ckfree(ZipFS.fallbackEntryEncoding);
+ ZipFS.initialized = -1;
+}
+
+static void
+ZipfsMountExitHandler(
+ ClientData clientData)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ ZipFile *zf = (ZipFile *) clientData;
+
+ if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
+ Tcl_Panic("tried to unmount busy filesystem");
+ }
+
+ hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ if (hPtr == NULL) {
+ ZipfsFinalize();
+ }
+
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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, ZIPFS_APP_MOUNT, archive, 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], -1, &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, ZIPFS_APP_MOUNT, archive, 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 *), /* Mount point path. */
+ TCL_UNUSED(const char *), /* Path to ZIP file to mount. */
+ 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 char *), /* Mount point path. */
+ TCL_UNUSED(unsigned char *),
+ TCL_UNUSED(size_t),
+ 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;
+}
+
+#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..1d64877 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.
@@ -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,
@@ -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", NULL);
+ } else {
+ Tcl_AppendResult(interp, "Comment too large for zip", 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", NULL);
+ } else {
+ Tcl_AppendResult(
+ interp, "Filename too large for zip", 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;
@@ -569,7 +578,7 @@ ExtractHeader(
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
&tmp);
- SetValue(dictObj, "comment", TclDStringToObj(&tmp));
+ SetValue(dictObj, "comment", Tcl_DStringToObj(&tmp));
}
SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
if (headerPtr->name != Z_NULL) {
@@ -586,13 +595,13 @@ ExtractHeader(
Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1,
&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",
@@ -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 == TclGetBytesFromObj(NULL,
+ compressionDictionaryObj, (int *)NULL))) {
+ /* Missing or invalid compression dictionary */
+ compressionDictionaryObj = NULL;
+ }
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
@@ -1214,6 +1228,7 @@ Tcl_ZlibStreamPut(
char *dataTmp = NULL;
int e;
int size, outSize, toStore;
+ unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
@@ -1224,8 +1239,13 @@ Tcl_ZlibStreamPut(
return TCL_ERROR;
}
+ bytes = TclGetBytesFromObj(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;
/*
@@ -1350,7 +1370,9 @@ Tcl_ZlibStreamGet(
return TCL_OK;
}
- (void) Tcl_GetByteArrayFromObj(data, &existing);
+ if (NULL == TclGetBytesFromObj(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)) {
@@ -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;
@@ -1599,6 +1621,16 @@ Tcl_ZlibDeflate(
}
/*
+ * Obtain the pointer to the byte array, we'll pass this pointer straight
+ * to the deflate command.
+ */
+
+ inData = TclGetBytesFromObj(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;
@@ -1749,6 +1775,11 @@ Tcl_ZlibInflate(
return TCL_ERROR;
}
+ inData = TclGetBytesFromObj(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);
}
@@ -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 = TclGetBytesFromObj(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 = TclGetBytesFromObj(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;
@@ -2339,6 +2375,12 @@ ZlibStreamSubcmd(
return TCL_ERROR;
}
+ if (compDictObj) {
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
+ return TCL_ERROR;
+ }
+ }
+
/*
* Construct the stream now we know its configuration.
*/
@@ -2390,7 +2432,7 @@ 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;
@@ -2473,7 +2515,7 @@ ZlibPushSubcmd(
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", 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) {
@@ -2517,6 +2559,10 @@ ZlibPushSubcmd(
}
}
+ if (compDictObj && (NULL == TclGetBytesFromObj(interp, compDictObj, 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[])
@@ -2762,7 +2808,10 @@ ZlibStreamAddCmd(
if (compDictObj != NULL) {
int len;
- (void) Tcl_GetByteArrayFromObj(compDictObj, &len);
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
+ return TCL_ERROR;
+ }
+
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[])
@@ -2866,7 +2915,9 @@ ZlibStreamPutCmd(
if (compDictObj != NULL) {
int len;
- (void) Tcl_GetByteArrayFromObj(compDictObj, &len);
+ if (NULL == TclGetBytesFromObj(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[])
@@ -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 == TclGetBytesFromObj(interp, compDictObj, NULL)) {
+ Tcl_DecrRefCount(compDictObj);
+ return TCL_ERROR;
+ }
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
@@ -3390,7 +3449,7 @@ ZlibTransformSetOption( /* not used */
static int
ZlibTransformGetOption(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
@@ -3446,7 +3505,7 @@ ZlibTransformGetOption(
} else {
if (cd->compDictObj) {
int len;
- const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len);
+ const char *str = TclGetStringFromObj(cd->compDictObj, &len);
Tcl_DStringAppend(dsPtr, str, len);
}
@@ -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);
+ TclGetByteArrayFromObj(cd->compDictObj, NULL);
}
if (format == TCL_ZLIB_FORMAT_RAW) {
@@ -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);
}
/*
@@ -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(int))
{
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(int))
{
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..e7c954d 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 $mountpoint ${basename}_library]
+ lappend dirs [file join $root lib $mountpoint]
+ 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 $mountpoint $dllfile
+ 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 $mountpoint $archive
+ 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 $archive}
+ }
+ }
+ }
+ }
+ }
+
# 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 abe6c81..be4abf8 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.
#
@@ -3313,7 +3313,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/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/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..a8db3cb 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -7,72 +7,70 @@
# 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(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(::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(::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 984f5c1..ff3f250 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,7 +22,7 @@ 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]
@@ -400,7 +400,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 +447,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 +792,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 +1134,37 @@ 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} {
+ set print ""
+ foreach c [split $s ""] {
+ if {[string is print $c] && (($c <= "\x7E") || ($c == "\n"))} {
+ append print $c
+ } elseif {$c <= "\xFF"} {
+ append print \\x[format %02X [scan $c %c]]
+ } elseif {$c <= "\xFFFF"} {
+ append print \\u[format %04X [scan $c %c]]
+ } else {
+ append print \\U[format %08X [scan $c %c]]
+ }
+ }
+ return $print
+}
+
# tcltest::ConstraintInitializer --
#
# Get or set a script that when evaluated in the tcltest namespace
@@ -1340,7 +1371,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 +2221,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 +2252,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} {
@@ -2901,7 +2936,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 {
@@ -3101,7 +3136,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
@@ -3252,7 +3287,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/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..4bd8f6c 100644
--- a/libtommath/tommath.h
+++ b/libtommath/tommath.h
@@ -4,7 +4,8 @@
#ifndef BN_H_
#define BN_H_
-#ifndef MP_NO_STDINT
+#if !defined(MP_NO_STDINT) && !defined(_STDINT_H) && !defined(_STDINT_H_) \
+ && !defined(__CLANG_STDINT_H) && !defined(_STDINT)
# include <stdint.h>
#endif
#include <stddef.h>
@@ -32,7 +33,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 +45,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 +69,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 +262,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 +318,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 +340,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 +353,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 +370,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 +570,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 +733,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 654d294..138d39e 100644
--- a/libtommath/tommath_private.h
+++ b/libtommath/tommath_private.h
@@ -4,7 +4,14 @@
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_
-#include <tommath.h>
+#ifdef MP_NO_STDINT
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#else
+# include "../compat/stdint.h"
+#endif
+#endif
+#include "tclTomMath.h"
#include "tommath_class.h"
/*
@@ -150,8 +157,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 +187,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 +224,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,6 +251,14 @@ 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) \
@@ -304,7 +321,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..aa0a8cb
--- /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..37bccf7
--- /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..ace8fce
--- /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..68b9418 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 */; };
@@ -377,7 +376,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 +393,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 +533,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 +575,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 +610,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 +763,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 +822,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 +831,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>"; };
@@ -1134,7 +1123,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 +1141,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 +1311,6 @@
F96D3F3508F272A7004A47F5 /* tclUtil.c */,
F96D3F3608F272A7004A47F5 /* tclVar.c */,
F96437C90EF0D4B2003F468E /* tclZlib.c */,
- F96D3F3708F272A7004A47F5 /* tommath.h */,
);
path = generic;
sourceTree = "<group>";
@@ -1436,6 +1424,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 +1459,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 +1645,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 +1666,7 @@
children = (
F96D444008F272B9004A47F5 /* aclocal.m4 */,
F96D444108F272B9004A47F5 /* configure */,
- F96D444208F272B9004A47F5 /* configure.in */,
+ F96D444208F272B9004A47F5 /* configure.ac */,
F96D444308F272B9004A47F5 /* dltest */,
F96D444D08F272B9004A47F5 /* install-sh */,
F96D444E08F272B9004A47F5 /* installManPage */,
@@ -1750,7 +1727,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 +1736,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 +1912,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 +1925,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 +2041,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 +2076,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 +2131,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 +2369,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 +2411,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 +2516,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 +2554,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 +2591,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 +2599,6 @@
};
name = DebugLeaks;
};
- F99EE73D0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugUnthreaded;
- };
F99EE73E0BE835310060D4AF /* DebugLeaks */ = {
isa = XCBuildConfiguration;
buildSettings = {
@@ -2726,17 +2606,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 +2617,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 +2694,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 +2761,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 +2781,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 +2803,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 +2825,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 +2847,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..0fbc7a3 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,11 +192,11 @@ 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;
@@ -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) {
@@ -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,12 +636,12 @@ 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) {
@@ -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 0b06c8f..c0c0cce 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 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.
@@ -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 0b2beb9..121b704 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 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/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 42c268a..b656894 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.
@@ -781,7 +781,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 {
@@ -852,10 +852,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} {
@@ -1110,10 +1111,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..c51d0e9 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,7 +2708,7 @@ 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-73.1 {binary decode base64} -body {
@@ -2645,19 +2725,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 +2748,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 +2855,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 +2906,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 +2929,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 +2961,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 +2985,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 +3012,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 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
+ testbytestring "乎"
+} -result "expected byte sequence but character 0 was '乎' (U+004E4E)"
+test binary-80.2 {TclGetBytesFromObj} -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 {TclGetBytesFromObj} -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 {TclGetBytesFromObj} -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 6062605..179d7a7 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]
@@ -1098,7 +1104,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
-} -result [list 15 "1234567890123\uFF10\uFF11" 18 0 1 -1 ""]
+} -result [list 15 "123456789012301" 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} {fcopy notWinCI} {
# 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]
@@ -6830,7 +6890,7 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} {
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
@@ -7527,7 +7587,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 c30fea3..0b385c9 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]]
}
@@ -35474,7 +35470,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
@@ -35490,7 +35486,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
@@ -36793,16 +36789,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 \
@@ -36934,10 +36930,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..f024f36 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,520 @@ 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 ""
+}
+
+# Map arbitrary strings to printable form in ASCII.
+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
+}
+
+#
+# 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
+} \u4e4e -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
+} \u4e4e -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 \u4e4e
+} \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 \u4e4e
+} \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 [printable $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 [printable $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 [printable $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 [printable $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 +770,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 +914,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 +1412,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 +1525,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 +1667,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 +1692,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 +1795,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 +1858,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 +1958,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 +1995,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 +2027,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 +2159,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 59b3459..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]} {
@@ -523,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..eb91a1d 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
@@ -240,25 +249,25 @@ test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
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 [encoding convertto iso2022 乎]
} [viewable "\x1B\$B8C\x1B(B"]
test encoding-11.5.1 {LoadEncodingFile: escape file} {
- viewable [encoding convertto iso2022-jp \u4E4E]
+ viewable [encoding convertto iso2022-jp 乎]
} [viewable "\x1B\$B8C\x1B(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
set system [encoding system]
@@ -273,7 +282,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 +291,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} {
+ viewable [encoding convertto utf-16le 😹]
+} {=Ø9Þ (=\u00D89\u00DE)}
+test encoding-11.9 {encoding: extended Unicode UTF-16} {
+ viewable [encoding convertto utf-16be 😹]
+} {Ø=Þ9 (\u00D8=\u00DE9)}
+test encoding-11.10 {encoding: extended Unicode UTF-32} {
+ viewable [encoding convertto utf-32le 😹]
+} "9\xF6\x01\x00 (9\\u00F6\\u0001\\u0000)"
+test encoding-11.11 {encoding: extended Unicode UTF-32} {
+ viewable [encoding convertto utf-32be 😹]
+} "\x00\x01\xF69 (\\u0000\\u0001\\u00F69)"
# 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 [set x [encoding convertto iso2022 ab乎棙g]]
} [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"
-
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
@@ -335,113 +348,315 @@ 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]
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 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 {Utf16ToUtfProc} -body {
+ set val [encoding convertfrom 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.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.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 utf-32le \x00\xD8\x00\x00
+} -result \uD800
+test encoding-16.10 {Utf32ToUtfProc} -body {
+ encoding convertfrom utf-32le \x00\xDC\x00\x00
+} -result \uDC00
+test encoding-16.11 {Utf32ToUtfProc} -body {
+ encoding convertfrom utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00
+} -result \uD800\uDC00
+test encoding-16.12 {Utf32ToUtfProc} -body {
+ encoding convertfrom utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00
+} -result \uDC00\uD800
+test encoding-16.13 {Utf16ToUtfProc} -body {
+ encoding convertfrom utf-16le \x00\xD8
+} -result \uD800
+test encoding-16.14 {Utf16ToUtfProc} -body {
+ encoding convertfrom 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 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 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom 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 {Utf16ToUtfProc, bug [d19fe0a5b]} -constraints deprecated -body {
+ encoding convertfrom utf-16 "\xD8\xD8"
} -result \uD8D8
+test encoding-16.21 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom utf-32 "\x00\x00\x00\x00\x41\x41"
+} -result \x00\uFFFD
+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 utf-32 "\xFF\xFF\xFF\xFF"
+} -result \uFFFD
+test encoding-16.25 {Utf32ToUtfProc} -body {
+ encoding convertfrom 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 {UtfToUtf16Proc} -body {
+ encoding convertto utf-32le "\U460DC"
+} -result "\xDC\x60\x04\x00"
+test encoding-17.6 {UtfToUtf16Proc} -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 {
+test encoding-18.1 {TableToUtfProc on invalid input} -constraints deprecated -body {
list [catch {encoding convertto 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 -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 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 -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]
@@ -528,7 +743,7 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
viewable [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
}]
@@ -538,7 +753,7 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# 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]"]
@@ -547,32 +762,134 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
close $f
removeFile iso2022.tcl
list $count [viewable $line]
-} [list 3 "\u4E4E\u4E5E\u4E5F (\\u4E4E\\u4E5E\\u4E5F)"]
+} [list 3 "乎乞也 (\\u4E4E\\u4E5E\\u4E5F)"]
test encoding-24.4 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC0\x80"]
} 1
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 valid or invalid utf-8} -constraints deprecated -body {
+ encoding convertfrom utf-8 "\xC0\x81"
+} -result \xC0\x81
+test encoding-24.13 {Parse valid or invalid utf-8} -constraints deprecated -body {
+ encoding convertfrom utf-8 "\xC1\xBF"
+} -result \xC1\xBF
+test encoding-24.14 {Parse valid or invalid utf-8} {
+ string length [encoding convertfrom utf-8 "\xC2\x80"]
} 1
+test encoding-24.15 {Parse valid or invalid utf-8} -constraints deprecated -body {
+ encoding convertfrom 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 {Parse valid or invalid utf-8} -constraints deprecated -body {
+ encoding convertto utf-8 "ZX\uD800"
+} -result ZX\xED\xA0\x80
+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 noncharacter with -profile strict} -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} -constraints deprecated -body {
+ encoding convertfrom 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 {Try to generate invalid utf-8} -constraints deprecated -body {
+ encoding convertto utf-8 \uD800
+} -result \xED\xA0\x80
+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 +1013,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,15 +1044,17 @@ 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
@@ -743,39 +1062,54 @@ test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExtern
testencoding
} -body {
# Note - buffers are initialized to \xff
- list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 1} result] $result
+ 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
+ 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
+ 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
+ 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 ucs2 knownBug
} -body {
+ # The knownBug constraint is because test depends on TCL_UTF_MAX and
+ # also UtfToUtf16 assumes space required in destination buffer is
+ # sizeof(Tcl_UniChar) which is incorrect when TCL_UTF_MAX==4
# 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}
+
+
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
diff --git a/tests/encodingVectors.tcl b/tests/encodingVectors.tcl
new file mode 100644
index 0000000..986e221
--- /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 knownBug {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 01f832e..985bce1 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 by 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 {
@@ -356,7 +351,7 @@ test expr-8.11 {CompileEqualityExpr: error compiling equality arm} -body {
expr 2!=x
} -returnCodes error -match glob -result *
test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1
-test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq [set s \u00fc]}} 1
+test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq [set s \xFC]}} 1
test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0
test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1
@@ -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,8 +1421,8 @@ 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
@@ -5848,7 +5825,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 "
@@ -5862,7 +5839,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 {
@@ -5882,7 +5859,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 {
@@ -5962,17 +5939,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}
@@ -6765,8 +6742,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 \
@@ -6791,8 +6768,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 \
@@ -7277,6 +7254,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
@@ -7314,14 +7489,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 1e6045b..d62a59a 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]]
@@ -390,13 +389,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 +692,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 +704,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 +717,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 +745,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 +775,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 43100bc..c5053e8 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,49 +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}
-test format-1.13 {integer formatting} longIs32bit {
- format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12}
-test format-1.13.1 {integer formatting} longIs64bit {
- format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12}
-test format-1.14 {integer formatting} longIs32bit {
- format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0 6 34 16923 -12}
-test format-1.14.1 {integer formatting} longIs64bit {
- format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0 6 34 16923 -12}
-test format-1.15 {integer formatting} longIs32bit {
- format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12 }
-test format-1.15.1 {integer formatting} longIs64bit {
- format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12 }
+} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+test format-1.13 {integer formatting} {
+ format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
+} {0 0d6 0d34 0d16923 -0d12}
+test format-1.14 {integer formatting} {
+ format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
+test format-1.15 {integer formatting} {
+ format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-2.1 {string formatting} {
@@ -116,17 +105,17 @@ 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"
+ format "%10s" abc\uFEFFdef
+} " abc\uFEFFdef"
test format-2.7 {string formatting, international chars} {
- format "%.5s" abc\ufeffdef
-} "abc\ufeffd"
+ format "%.5s" abc\uFEFFdef
+} "abc\uFEFFd"
test format-2.8 {string formatting, international chars} {
- format "foo\ufeffbar%s" baz
-} "foo\ufeffbarbaz"
+ format "foo\uFEFFbar%s" baz
+} "foo\uFEFFbarbaz"
test format-2.9 {string formatting, width} {
format "a%5sa" f
} "a fa"
@@ -154,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
@@ -278,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} {
@@ -373,9 +368,9 @@ test format-8.19 {error conditions} {
catch {format %q x}
} 1
test format-8.20 {error conditions} {
- catch {format %q x} msg
+ catch {format %r x} msg
set msg
-} {bad field specifier "q"}
+} {bad field specifier "r"}
test format-8.21 {error conditions} {
catch {format %d}
} 1
@@ -387,6 +382,26 @@ 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-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}
@@ -540,7 +555,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} {
@@ -554,7 +569,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}
@@ -573,7 +588,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..079166e 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,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 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 +43,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 +63,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 +97,23 @@ 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}
+} {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 " "09" "- 0" "-0" "0o12" "0b10"} {
+ lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} {
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 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
+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 " 0x_a " 0b1111_1111 " 0_07 " " 0o_1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 } {
+ catch {testgetint $x} x
+ set x
+ }
+} {0 10 2 33 1423324 10 255 7 8 2 {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"}}
# 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 e589351..c5babdd 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 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.
diff --git a/tests/incr-old.test b/tests/incr-old.test
index 5d792e1..818bccc 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.
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..2c50200 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,52 @@ 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
+} 0
+test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
+ testgetintforindex end+1 -2
+} -1
+
# 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 91df4a1..4acad3d 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 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 {"::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 031f857..1efd69c 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]
@@ -48,6 +48,8 @@ testConstraint testservicemode [llength [info commands testservicemode]]
testConstraint notWinCI [expr {
$::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
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}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
@@ -77,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} {
@@ -108,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"
@@ -272,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
@@ -286,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
@@ -299,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)]
@@ -319,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
@@ -466,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
@@ -484,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
@@ -517,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
@@ -938,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
@@ -1036,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
@@ -1067,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+]
@@ -1101,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)
@@ -1134,7 +1136,7 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
lappend x [gets $f line] $line
close $f
set x
-} [list 15 "1234567890123\uFF10\uFF11" 18 0 1 -1 ""]
+} [list 15 "123456789012301" 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
@@ -1153,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)
@@ -1182,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
@@ -1436,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
@@ -1469,7 +1471,7 @@ 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
@@ -1479,7 +1481,7 @@ test io-12.6 {ReadChars: too many chars read} {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
- [string repeat \uBEEF 20][string repeat . 20]]
+ [string repeat 뻯 20][string repeat . 20]]
return {initialize finalize watch read}
}
finalize {
@@ -1512,7 +1514,7 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
- [string repeat \uBEEF 10]....\uBEEF]
+ [string repeat 뻯 10]....뻯]
return {initialize finalize watch read}
}
finalize {
@@ -2392,6 +2394,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}}
@@ -3314,7 +3384,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
@@ -3326,11 +3396,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
@@ -3347,7 +3417,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]
@@ -3367,7 +3437,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]
@@ -3445,7 +3515,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
@@ -3459,7 +3529,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
@@ -3473,7 +3543,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
@@ -3487,7 +3557,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
@@ -3501,7 +3571,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
@@ -3515,7 +3585,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
@@ -3848,7 +3918,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]
@@ -3863,11 +3933,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]
@@ -3887,7 +3957,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]
@@ -3905,7 +3975,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]
@@ -3989,7 +4059,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]
@@ -4007,7 +4077,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]
@@ -4025,7 +4095,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]
@@ -4043,7 +4113,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]
@@ -4061,7 +4131,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]
@@ -4079,7 +4149,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]
@@ -4960,12 +5030,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
@@ -4974,12 +5044,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
@@ -4988,12 +5058,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
@@ -5002,12 +5072,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
@@ -5016,12 +5086,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
@@ -5030,12 +5100,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
@@ -5050,7 +5120,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
@@ -5065,7 +5135,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
@@ -5080,7 +5150,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
@@ -5095,7 +5165,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
@@ -5110,7 +5180,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
@@ -5125,7 +5195,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
@@ -5148,12 +5218,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
@@ -5162,12 +5232,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
@@ -5196,7 +5266,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
@@ -5211,7 +5281,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
@@ -5406,7 +5476,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]
@@ -5594,7 +5664,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]
@@ -5606,7 +5676,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]
@@ -5702,7 +5772,7 @@ test io-39.22 {Tcl_SetChannelOption, invariance} {unix} {
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
@@ -5713,7 +5783,7 @@ test io-39.22a {Tcl_SetChannelOption, invariance} {
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
@@ -5752,11 +5822,11 @@ test io-40.1 {POSIX open access modes: RDWR} {
close $f
set x
} {zzy abzzy}
-test io-40.2 {POSIX open access modes: CREAT} {unix} {
+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]
@@ -5764,7 +5834,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} {
close $f
set x
} {0o600 {line 1}}
-test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
+test io-40.3 {POSIX open access modes: CREAT} {unix umask notWsl} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
@@ -6086,6 +6156,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} {
@@ -6414,7 +6548,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]
@@ -6442,7 +6576,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]
@@ -6470,7 +6604,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]
@@ -6498,7 +6632,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]
@@ -6526,7 +6660,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]
@@ -6554,7 +6688,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]
@@ -6582,7 +6716,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]
@@ -6610,7 +6744,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]
@@ -6638,7 +6772,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]
@@ -6666,7 +6800,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]
@@ -6694,7 +6828,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]
@@ -6722,7 +6856,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]
@@ -7114,8 +7248,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
@@ -7155,8 +7289,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
@@ -7172,8 +7306,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
@@ -7189,8 +7323,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
@@ -7206,8 +7340,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
@@ -7223,8 +7357,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]
@@ -7269,7 +7403,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.
@@ -7301,7 +7435,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} {fcopy notWinCI} {
# encoding to binary (=> implies that the
# internal utf-8 is written)
@@ -7321,7 +7455,7 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} {
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
@@ -7484,6 +7618,103 @@ 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.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.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)
@@ -7501,8 +7732,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
@@ -7980,7 +8211,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 {
@@ -7999,6 +8230,32 @@ 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
@@ -8465,7 +8722,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]
@@ -8799,7 +9056,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]
@@ -8807,7 +9064,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]
@@ -8829,17 +9086,17 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup {
# 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.
+# TCL 8.7 only offers tolerant channel encoding, what is tested here.
test io-75.1 {multibyte encoding error read results in raw bytes} -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
@@ -8847,54 +9104,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
@@ -8902,29 +9159,294 @@ 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 {invalid utf-8 encoding gets is not ignored (-profile strict)} -setup {
+ set fn [makeFile {} io-75.6]
+ 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 {
+ gets $f
+} -cleanup {
+ close $f
+ removeFile io-75.6
+} -match glob -returnCodes 1 -result {error reading "*": invalid or incomplete multibyte or wide character}
+
+test io-75.7 {invalid utf-8 encoding gets 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 {
+ read $f
+} -cleanup {
+ close $f
+ removeFile io-75.7
+} -match glob -returnCodes 1 -result {error reading "*": invalid or incomplete multibyte or wide character}
+
+test io-75.8 {invalid utf-8 encoding eof 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]
+ close $f
+ set hd
+} -cleanup {
+ removeFile io-75.8
+} -result {41 1 {}}
+
+test io-75.9 {unrepresentable character write passes and is replaced by ?} -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
+} -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
+} -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 raw bytes} -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]
+ lappend hd $msg
+} -cleanup {
+ close $f
+ removeFile io-75.11
+} -match glob -result {41 1 {error reading "*": invalid or incomplete multibyte or wide character}}
+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]
+ lappend hd $msg
+} -cleanup {
+ close $f
+ removeFile io-75.13
+} -match glob -result {41 1 {error reading "*": invalid or incomplete multibyte or wide character}}
# ### ### ### ######### ######### #########
+
+
+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..e132b9a 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.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-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 +20,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 +153,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 +205,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" {}]
+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 +305,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 +348,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 +359,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 +518,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
@@ -911,6 +954,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 +1072,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 +1387,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 +1396,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 +1408,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 +2037,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 +2072,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 +2383,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 +2929,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 +2942,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 +2958,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} {
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 d37f08a..43a85fb 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 {
@@ -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..0f43648 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,73 @@ 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 {}}
+
# 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..009170e 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,303 @@ 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}
+
+# 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..b8ae2e9
--- /dev/null
+++ b/tests/lseq.test
@@ -0,0 +1,552 @@
+# 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
+
+## 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} {
+ 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} }
+} {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} {
+ 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
+ }
+ unset factor
+ unset l
+ set ans
+} {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} {
+ set s [lseq 25 by 6]
+ list $s length=[llength $s]
+} {{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} {
+ lmap x [lseq 5] { expr {$x * $x} }
+} {0 1 4 9 16}
+
+test lseq-3.8 {lrange lseq} {
+ 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]
+} {{11 12 13 14 15 16 17 18 19 20 21} {} arithseries}
+
+test lseq-3.9 {lassign lseq} arithSeriesShimmer {
+ 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]
+} {arithseries 0 1 arithseries}
+
+test lseq-3.10 {lsearch lseq must shimmer?} arithSeriesShimmer {
+ set r [lseq 15 0]
+ set a [lsearch $r 9]
+ list [lindex [tcl::unsupported::representation $r] 3] $a
+} {arithseries 6}
+
+test lseq-3.11 {lreverse lseq} {
+ 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
+} {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} {
+ 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]
+} {1 1 0 0 arithseries}
+
+test lseq-3.13 {lmap lseq shimmer} arithSeriesShimmer {
+ 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
+} {{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} arithSeriesShimmerOk {
+ 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}
+} {arithseries {1 1 1} {1 1 1} arithseries}
+
+test lseq-3.15 {join for shimmer} arithSeriesShimmer {
+ 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}
+} {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} arithSeriesShimmer {
+ 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}
+} {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} {} {
+ set r [lseq -5 17 3]
+ set rr [lreverse $r]
+ list $r $rr [string equal $r [lreverse $rr]]
+} {{-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} arithSeriesDouble {
+ 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
+} {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.599999999999998 29.299999999999997 29.0 28.7 28.4 28.099999999999998 27.799999999999997 27.5 27.2 26.9 26.599999999999998 26.299999999999997 26.0 25.7 25.4 25.099999999999998 24.799999999999997 24.5 24.2 23.9 23.599999999999998 23.299999999999997 23.0 22.7 22.4 22.099999999999998 21.799999999999997 21.5 21.2 20.9 20.6 20.299999999999997 20.0 19.7 19.4 19.1 18.799999999999997 18.5 18.2 17.9 17.6 17.299999999999997 17.0 16.7 16.4 16.1 15.799999999999999 15.5 15.2 14.899999999999999 14.6 14.299999999999999 14.0 13.7 13.399999999999999 13.099999999999998 12.8 12.5 12.2 11.899999999999999 11.599999999999998 11.3 11.0 10.7 10.399999999999999 10.099999999999998 9.8 9.5 9.2 8.899999999999999 8.599999999999998 8.3 8.0 7.699999999999999 7.399999999999999 7.099999999999998 6.800000000000001 6.5 6.199999999999999 5.899999999999999 5.599999999999998 5.300000000000001 5.0 4.699999999999999 4.399999999999999 4.099999999999998 3.8000000000000007 3.5 3.1999999999999993 2.8999999999999986 2.599999999999998 2.3000000000000007 2.0 1.6999999999999993 1.3999999999999986 1.1000000000000014}
+
+test lseq-4.1 {end expressions} {
+ set start 7
+ lseq $start $start+11
+} {7 8 9 10 11 12 13 14 15 16 17 18}
+
+test lseq-4.2 {start expressions} {
+ set base [clock seconds]
+ set tl [lseq $base-60 $base 10]
+ lmap t $tl {expr {$t - $base + 60}}
+} {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} {
+ 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
+ }
+
+ 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
+} {{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
+} -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}]
+} -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
+ unset e
+} -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
+} -returnCodes 1 \
+ -result {bad index "fred": must be integer?[+-]integer? or end?[+-]integer?}
+
+test lseq-4.9 {error case lrange} -body {
+ set fred 7
+ set ginger 8
+ lrange [lseq 1 5] $fred $ginger
+} -returnCodes 1 \
+ -result {index 7 is out of bounds 0 to 4}
+
+# 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 e4715f8..06eedfd 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 by 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..ff67cc1 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::object ::oo::singleton} {::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::abstract ::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]
@@ -1670,10 +1739,10 @@ test oo-11.6.4 {
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 {}
@@ -2389,7 +2458,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, 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 +2588,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 +2677,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, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -2640,6 +2776,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 +3961,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 +3987,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 +4094,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 +4133,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 +4141,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 +4149,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 +4188,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 +4197,7 @@ 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, -clear, -prepend, -remove, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
@@ -4069,25 +4227,68 @@ proc getMethods obj {
}
test oo-34.3 {TIP 380: slots - presence} {
getMethods oo::define::filter
-} {{-append -clear -set} {Get Set}}
+} {{-append -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 -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 -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 -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
getMethods oo::objdefine::filter
-} {{-append -clear -set} {Get Set}}
+} {{-append -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 -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 -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 +4360,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 +4382,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/ooUtil.test b/tests/ooUtil.test
new file mode 100644
index 0000000..f41c668
--- /dev/null
+++ b/tests/ooUtil.test
@@ -0,0 +1,563 @@
+# 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 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..c70c5e3 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 "
@@ -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 a92c6ab..ab93fca 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 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/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..41c4b78
--- /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 $ZipMountPoint [file join $TestsDir auto-files.zip]
+
+ 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..052bd23 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.
@@ -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
@@ -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}
diff --git a/tests/set.test b/tests/set.test
index 303c2d7..357e34b 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]]
diff --git a/tests/socket.test b/tests/socket.test
index 7251bfa..82e908a 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,16 +2566,17 @@ 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
}
}
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..ade673e 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,47 @@ 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 testobj [expr {[info commands testobj] ne {}}]
+testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
+testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf16 [expr {[string length \U010000] == 2}]
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 +77,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 +122,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 +145,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 +175,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 +198,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} {
@@ -178,13 +234,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 +254,119 @@ 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-4.1.$noComp {string first, not enough args} {
list [catch {run {string first a}} msg] $msg
@@ -224,19 +393,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 +414,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 +435,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 +453,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 +471,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 +508,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]} -constraints utf16 -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 +530,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 +556,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 +564,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 +588,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 +630,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 +689,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 +711,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 +720,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 +758,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 +767,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 +822,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 +860,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 +966,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 +1014,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 +1040,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 +1072,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 +1092,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 +1113,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 +1323,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 +1436,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 +1490,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}]
@@ -1332,6 +1528,20 @@ test string-12.22.$noComp {string range, shimmering binary/index} {
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 {
run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
} [list \U100000 {} b]
+test string-12.24.$noComp {bignum index arithmetic} -setup {
+ proc demo {i j} {string range fubar $i $j}
+} -cleanup {
+ rename demo {}
+} -body {
+ 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 +1577,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 +1643,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 +1795,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]} utf16 {
+ 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 +1852,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 +1886,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 +1936,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} -constraints utf16 -body {
+ run {string wordend "\U1D7CA\U1D7CA abc" 10}
+} -result 8
test string-21.17.$noComp {string trim, unicode} {
run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02}
} "Hello world!"
@@ -1693,7 +1972,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 +2014,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} -constraints utf16 -body {
+ run {string wordstart "\U1D7CA\U1D7CA abc" 10}
+} -result 5
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
@@ -2134,6 +2419,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 +2474,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..60e1294 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,16 @@ 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 {
+testConstraint tip389 [expr {[string length \U010000] == 2}]
+testConstraint utf32 [expr {[string length [format %c 0x10000]] == 1}]
+
+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 +58,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 utf32 deprecated} {
testobj freeallvars
teststringobj set 1 test
teststringobj setlength 1 3
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
-} {3 4 tes}
-test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj {
+} {3 3 tes}
+test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} {
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 utf32 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 +98,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 utf32 deprecated} {
testobj freeallvars
teststringobj set 1 xyz
teststringobj setlength 1 15
@@ -107,7 +110,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 +136,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 utf32 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 +151,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 utf32 deprecated} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
@@ -156,8 +159,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 +173,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 utf32 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 +198,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 utf32 deprecated} {
testobj freeallvars
teststringobj set 1 {}
teststringobj append 1 abcde -1
@@ -204,21 +207,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 +238,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 +280,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 +308,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 +329,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 +339,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 +384,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 +406,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 +431,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 +456,52 @@ 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 tip389 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 tip389 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 tip389 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 tip389 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 = -1} {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 = -1} {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: fist = last = -1} {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
} {}
-
if {[testConstraint testobj]} {
testobj freeallvars
@@ -519,3 +510,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..61366a4 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]
@@ -45,5 +65,5 @@ namespace eval ::tcltests {
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 c1e1a24..3f30048 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,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 testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
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 51ecafe..8e64c7a 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 {}
@@ -87,13 +92,15 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
skip [concat [skip] unixInit-2.*]
-test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {
- set origDir [testgetdefenc]
- testsetdefenc slappy
- set path [testgetdefenc]
- testsetdefenc $origDir
+test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints {
+ testgetencpath
+} -body {
+ set origPath [testgetencpath]
+ testsetencpath slappy
+ set path [testgetencpath]
+ testsetencpath $origPath
set path
-} {slappy}
+} -result {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup {
unset -nocomplain oldlibrary
if {[info exists env(TCL_LIBRARY)]} {
@@ -119,7 +126,7 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup {
set oldlibrary $env(TCL_LIBRARY)
}
} -body {
- # ((str != NULL) && (str[0] != '\0'))
+ # ((str != NULL) && (str[0] != '\x00'))
set env(TCL_LIBRARY) sparkly
lindex [getlibpath] 0
} -cleanup {
@@ -151,7 +158,7 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup {
}
} -body {
# Child process translates env variable from native encoding.
- set env(TCL_LIBRARY) "\xa7"
+ set env(TCL_LIBRARY) "§"
lindex [getlibpath] 0
} -cleanup {
unset -nocomplain env(TCL_LIBRARY) env(LANG)
@@ -159,7 +166,7 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup {
set env(TCL_LIBRARY) $oldlibrary
unset oldlibrary
}
-} -result "\xa7"
+} -result "§"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} {
# cannot test
} {}
@@ -339,7 +346,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+]
@@ -357,6 +366,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 9e44a79..c31eaa1 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 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 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 871bdc8..5a6bbd4 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,7 +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]]
+
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
@@ -49,7 +51,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]}
@@ -84,6 +86,25 @@ test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} {
test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf 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"
@@ -110,10 +131,10 @@ test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testb
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
+ string length 𐀀
} 2
test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf32 {
- string length \U010000
+ 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]
@@ -172,12 +193,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
@@ -354,7 +372,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]
@@ -387,22 +405,22 @@ 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
@@ -533,127 +551,6 @@ test utf-6.95.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {
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 {
testutfprev {}
@@ -794,13 +691,13 @@ test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
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]
@@ -926,7 +823,7 @@ 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
@@ -969,14 +866,14 @@ 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
+ string index 乎ɚÿՃ 2
+} ÿ
test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 {
string index \uD842 0
} \uD842
@@ -993,116 +890,116 @@ 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
+ string index 😀G 0
+} 😀
test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 0
-} \U1F600
+ string index 😀G 0
+} 😀
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
+ string index 😀G 1
} G
test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 1
+ string index 😀G 1
} {}
test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 2
} G
test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 2
+ string index 😀G 2
} {}
test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 2
+ string index 😀G 2
} G
-test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
- string index \U1F600G 0
+test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
+ string index 😀G 0
} \uFFFD
test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 0
-} \U1F600
+ string index 😀G 0
+} 😀
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
+ string index 😀G 0
+} 😀
+test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
+ string index 😀G 1
} G
test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 1
+ string index 😀G 1
} G
test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 1
+ string index 😀G 1
} {}
-test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
- string index \U1F600G 2
+test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
+ string index 😀G 2
} {}
test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 2
+ string index 😀G 2
} {}
test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 2
+ string index 😀G 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
+ string range 乎ɚÿՃklmnop 1 5
+} ɚÿՃkl
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
+ string range 😀G 0 0
+} 😀
test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 {
- string range \U1F600G 0 0
-} \U1F600
+ string range 😀G 0 0
+} 😀
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
+ string range 😀G 1 1
} G
test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 1 1
+ string range 😀G 1 1
} {}
test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 2 2
+ string range 😀G 2 2
} {}
test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 2 2
+ string range 😀G 2 2
} G
-test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} {
- string range \U1F600G 0 0
+test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 {
+ string range 😀G 0 0
} \uFFFD
test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} utf32 {
- string range \U1F600G 0 0
-} \U1F600
+ string range 😀G 0 0
+} 😀
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
+ string range 😀G 0 0
+} 😀
+test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
+ string range 😀G 1 1
} G
test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 1 1
+ string range 😀G 1 1
} G
test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 1 1
+ string range 😀G 1 1
} {}
-test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
- string range \U1F600G 2 2
+test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
+ string range 😀G 2 2
} {}
test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 2 2
+ string range 😀G 2 2
} {}
test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 2 2
+ string range 😀G 2 2
} G
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
@@ -1205,17 +1102,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
+ string toupper აᲐ
+} ᲐᲐ
test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
- string toupper \U10428
-} \U10400
+ string toupper 𐐨
+} 𐐀
test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
- string toupper \uD801\uDC28
-} \uD801\uDC00
+ string toupper 𐐨
+} 𐐀
test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} {
string toupper \uDC24\uD824
} \uDC24\uD824
@@ -1227,23 +1124,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
+ string tolower 𐐀
+} 𐐨
test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf {
- string tolower \uD801\uDC00
-} \uD801\uDC28
+ string tolower 𐐀
+} 𐐨
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
@@ -1252,26 +1149,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
+ string totitle 𐐨𐐀
+} 𐐀𐐨
test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
- string totitle \uD801\uDC28\uD801\uDC00
-} \uD801\uDC00\uD801\uDC28
+ string totitle 𐐨𐐀
+} 𐐀𐐨
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
@@ -1290,8 +1187,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 !
} !
@@ -1300,25 +1197,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 !
} !
@@ -1332,7 +1229,7 @@ test utf-19.1 {TclUniCharLen} -body {
test utf-20.1 {TclUniCharNcmp} utf32 {
string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
} -1
-test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {
+test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} utf32 {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
@@ -1344,23 +1241,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]
@@ -1395,25 +1292,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} {
@@ -1442,8 +1339,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
@@ -1471,7 +1368,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
diff --git a/tests/utfext.test b/tests/utfext.test
new file mode 100644
index 0000000..bc996c9
--- /dev/null
+++ b/tests/utfext.test
@@ -0,0 +1,101 @@
+# 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
+}
+
+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
+ }
+}
+
+# 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]
+ 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]
+ }
+}
+
+#
+# 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]
+
+# 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ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
+
+::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 968337b..15edf6e 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 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]]
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..f030444 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..93b9242 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]
@@ -162,7 +163,7 @@ test winDde-3.6 {DDE request utf-8} -constraints dde -body {
} -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 {
+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
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 3d0a9e0..9b5e67e 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..28d4f5b 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 {
{\&|^<>!()%}
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/zipfs.test b/tests/zipfs.test
new file mode 100644
index 0000000..bf9c969
--- /dev/null
+++ b/tests/zipfs.test
@@ -0,0 +1,410 @@
+# 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.
+#
+# 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 zipfs [expr {
+ [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]
+}]
+testConstraint zipfslib 1
+
+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]} {
+ ###
+ # "make test" does not map tcl_library from the dynamic library on Unix
+ #
+ # Hack the environment to pretend we did pull tcl_library from a zip
+ # archive
+ ###
+ set tclzip [file join $CWD libtcl[info patchlevel].zip]
+ testConstraint zipfslib [file isfile $tclzip]
+ if {[testConstraint zipfslib]} {
+ zipfs mount /lib/tcl $tclzip
+ set ::tcl_library ${ziproot}lib/tcl/tcl_library
+ }
+}
+
+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 [zipfs root] bar baz
+} -result "[zipfs root]bar/baz"
+test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
+ file normalize [zipfs root]
+} -result "[zipfs root]"
+test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
+ file normalize [zipfs root]//bar/baz//qux/../
+} -result "[zipfs root]bar/baz"
+
+test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs mount a b c d e f
+} -result {wrong # args: should be "zipfs mount ?mountpoint? ?zipfile? ?password?"}
+test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs unmount a b c d e f
+} -result {wrong # args: should be "zipfs unmount zipfile"}
+test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs mkkey a b c d e f
+} -result {wrong # args: should be "zipfs mkkey password"}
+test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs mkimg a b c d e f
+} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"}
+test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs mkzip a b c d e f
+} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"}
+test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs exists a b c d e f
+} -result {wrong # args: should be "zipfs exists filename"}
+test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs info a b c d e f
+} -result {wrong # args: should be "zipfs info filename"}
+test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body {
+ zipfs list a b c d e f
+} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"}
+
+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 ${ziproot}abc $zipfile
+ zipfs list -glob ${ziproot}abc/cp850.*
+} -cleanup {
+ cd $CWD
+} -result "[zipfs root]abc/cp850.enc"
+testConstraint zipfsenc [zipfs exists /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 /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 def $dat
+ zipfs list -glob ${ziproot}def/cp850.*
+} -cleanup {
+ cd $CWD
+} -result "[zipfs root]def/cp850.enc"
+testConstraint zipfsencbuf [zipfs exists /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 /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 ziptest $targetImage
+ try {
+ list [source $targetImage] [source //zipfs:/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 ziptest $targetImage
+ try {
+ list [glob -tails -directory //zipfs://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 ziptest $targetImage
+ try {
+ glob -tails -directory //zipfs://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 ziptest $targetImage
+ try {
+ glob -tails -directory //zipfs://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 ziptest $midImage
+ set f [glob -directory //zipfs://ziptest/test *.tcl]
+ zipfs lmkimg $targetImage [list $f test/ok.tcl] {} $midImage
+ zipfs unmount ziptest
+ zipfs mount ziptest $targetImage
+ list $f [glob -directory //zipfs://ziptest/test *.tcl]
+} -cleanup {
+ zipfs unmount ziptest
+ removeFile $baseImage
+ removeFile $midImage
+ removeFile $targetImage
+ removeFile $addFile
+} -result {//zipfs://ziptest/test/add.tcl //zipfs://ziptest/test/ok.tcl}
+
+test zipfs-5.1 {zipfs mount_data: short data} -constraints zipfs -body {
+ zipfs mount_data gorp {}
+} -returnCodes error -result {bad zip data}
+test zipfs-5.2 {zipfs mount_data: short data} -constraints zipfs -body {
+ zipfs mount_data gorp gorpGORPgorp
+} -returnCodes error -result {bad zip data}
+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 gorp $data
+} -returnCodes error -result {bad zip data}
+test zipfs-5.4 {zipfs mount_data: bad arg count} -constraints zipfs -body {
+ zipfs mount_data gorp {} foobar
+} -returnCodes error -result {wrong # args: should be "zipfs mount_data ?mountpoint? ?data?"}
+
+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}
+
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/zlib.test b/tests/zlib.test
index 5312d2b..42d9e9c 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.
@@ -34,7 +34,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 +286,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
@@ -71,11 +71,6 @@ encodings: clean txt2enc $(EUC_ENCODINGS)
done
@echo
@echo Compiling special versions of encoding files.
- @for p in ascii.txt; do \
- enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \
- echo $$enc; \
- ./txt2enc -m $$p > $$enc; \
- done
@for p in jis0208.txt; do \
enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \
echo $$enc; \
diff --git a/tools/encoding/txt2enc.c b/tools/encoding/txt2enc.c
index 7ee797b..32c7344 100644
--- a/tools/encoding/txt2enc.c
+++ b/tools/encoding/txt2enc.c
@@ -106,7 +106,7 @@ main(int argc, char **argv)
fputs(" -f\tfallback character (default: QUESTION MARK)\n", stderr);
fputs(" -t\toverride implicit type with single, double, or multi\n", stderr);
fputs(" -s\tsymbol+ascii encoding\n", stderr);
- fputs(" -m\tdon't implicitly include range 0080 to 00FF\n", stderr);
+ fputs(" -m\tdon't implicitly include 007F\n", stderr);
return 1;
}
@@ -208,10 +208,8 @@ main(int argc, char **argv)
toUnicode[0][i] = i;
}
if (fixmissing) {
- for (i = 0x7F; i < 0xA0; i++) {
- if (toUnicode[i] == NULL && toUnicode[0][i] == 0) {
- toUnicode[0][i] = i;
- }
+ if (toUnicode[0x7F] == NULL && toUnicode[0][0x7F] == 0) {
+ toUnicode[0][0x7F] = 0x7F;
}
}
}
diff --git a/tools/eolFix.tcl b/tools/eolFix.tcl
deleted file mode 100644
index b3382ac..0000000
--- a/tools/eolFix.tcl
+++ /dev/null
@@ -1,78 +0,0 @@
-## Super aggressive EOL-fixer!
-##
-## Will even understand screwed up ones like CRCRLF.
-##
-## davygrvy@pobox.com 3:41 PM 10/12/2001
-##
-
-package provide EOL-fix 1.1
-
-namespace eval ::EOL {
- variable outMode crlf
-}
-
-proc EOL::fix {filename {newfilename {}}} {
- variable outMode
-
- if {![file exists $filename]} {
- return
- }
- puts "EOL Fixing: $filename"
-
- file rename ${filename} ${filename}.o
- set fhnd [open ${filename}.o r]
-
- if {$newfilename ne ""} {
- set newfhnd [open ${newfilename} w]
- } else {
- set newfhnd [open ${filename} w]
- }
-
- fconfigure $newfhnd -translation [list auto $outMode]
- seek $fhnd 0 end
- set theEnd [tell $fhnd]
- seek $fhnd 0 start
-
- fconfigure $fhnd -translation binary -buffersize $theEnd
- set rawFile [read $fhnd $theEnd]
- close $fhnd
-
- regsub -all {(\r)|(\r){1,2}(\n)} $rawFile "\n" rawFile
-
- set lineList [split $rawFile \n]
-
- foreach line $lineList {
- puts $newfhnd $line
- }
-
- close $newfhnd
- file delete ${filename}.o
-}
-
-proc EOL::fixall {args} {
- if {[llength $args] == 0} {
- puts stderr "no files to fix"
- exit 1
- } else {
- set cmd [lreplace $args -1 -1 glob -nocomplain]
- }
-
- foreach f [eval $cmd] {
- if {[file isfile $f]} {fix $f}
- }
-}
-
-if {$tcl_interactive == 0 && $argc > 0} {
- if {[string index [lindex $argv 0] 0] eq "-"} {
- switch -- [lindex $argv 0] {
- -cr {set ::EOL::outMode cr}
- -crlf {set ::EOL::outMode crlf}
- -lf {set ::EOL::outMode lf}
- default {puts stderr "improper mode switch"; exit 1}
- }
- set argv [lrange $argv 1 end]
- }
- eval EOL::fixall $argv
-} else {
- return
-}
diff --git a/tools/findBadExternals.tcl b/tools/findBadExternals.tcl
index 2228357..2351cd2 100755
--- a/tools/findBadExternals.tcl
+++ b/tools/findBadExternals.tcl
@@ -10,7 +10,7 @@
#
# tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll
#
-# Copyright (c) 2005 George Peter Staplin and Kevin Kenny
+# Copyright © 2005 George Peter Staplin and Kevin Kenny
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tools/fix_tommath_h.tcl b/tools/fix_tommath_h.tcl
deleted file mode 100755
index 8e92400..0000000
--- a/tools/fix_tommath_h.tcl
+++ /dev/null
@@ -1,102 +0,0 @@
-# fixtommath.tcl --
-#
-# Changes to 'tommath.h' to make it conform with Tcl's linking
-# conventions.
-#
-# Copyright (c) 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.
-#----------------------------------------------------------------------
-
-set f [open [lindex $argv 0] r]
-set data [read $f]
-close $f
-
-set eat_endif 0
-set eat_semi 0
-set def_count 0
-foreach line [split $data \n] {
- if {!$eat_semi && !$eat_endif} {
- switch -regexp -- $line {
- {#define BN_H_} {
- puts $line
- puts {}
- puts "\#include \"tclInt.h\""
- puts "\#include \"tclTomMathDecls.h\""
- puts "\#ifndef MODULE_SCOPE"
- puts "\#define MODULE_SCOPE extern"
- puts "\#endif"
- }
- {typedef\s+unsigned long\s+mp_digit;} {
- # change the second 'typedef unsigned long mp
- incr def_count
- puts "\#ifndef MP_DIGIT_DECLARED"
- if {$def_count == 2} {
- puts [string map {long int} $line]
- } else {
- puts $line
- }
- puts "\#define MP_DIGIT_DECLARED"
- puts "\#endif"
- }
- {typedef.*mp_digit;} {
- puts "\#ifndef MP_DIGIT_DECLARED"
- puts $line
- puts "\#define MP_DIGIT_DECLARED"
- puts "\#endif"
- }
- {typedef struct} {
- puts "\#ifndef MP_INT_DECLARED"
- puts "\#define MP_INT_DECLARED"
- puts "typedef struct mp_int mp_int;"
- puts "\#endif"
- puts "struct mp_int \{"
- }
- \}\ mp_int\; {
- puts "\};"
- }
- {^(char|int|void)} {
- puts "/*"
- puts $line
- set eat_semi 1
- set after_semi "*/"
- }
- {^extern (int|const)} {
- puts "\#if defined(BUILD_tcl) || !defined(_WIN32)"
- puts [regsub {^extern} $line "MODULE_SCOPE"]
- set eat_semi 1
- set after_semi "\#endif"
- }
- {define heap macros} {
- puts $line
- puts "\#if 0 /* these are macros in tclTomMathDecls.h */"
- set eat_endif 1
- }
- {__x86_64__} {
- puts "[string map {__x86_64__ NEVER} $line]\
- /* 128-bit ints fail in too many places */"
- }
- {#include} {
- # remove all includes
- }
- default {
- puts $line
- }
- }
- } else {
- puts $line
- }
- if {$eat_semi} {
- if {[regexp {; *$} $line]} {
- puts $after_semi
- set eat_semi 0
- }
- }
- if {$eat_endif} {
- if {[regexp {^\#endif} $line]} {
- puts "\#endif"
- set eat_endif 0
- }
- }
-}
diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl
index 4f4acbb..89e4ccc 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -4,8 +4,8 @@
# interface.
#
#
-# Copyright (c) 1998-1999 Scriptics Corporation.
-# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+# Copyright © 1998-1999 Scriptics Corporation.
+# 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.
@@ -257,7 +257,7 @@ proc genStubs::rewriteFile {file text} {
return
}
set in [open ${file} r]
- fconfigure $in -eofchar "\032 {}" -encoding utf-8
+ fconfigure $in -eofchar "\x1A {}" -encoding utf-8
set out [open ${file}.new w]
fconfigure $out -translation lf -encoding utf-8
diff --git a/tools/index.tcl b/tools/index.tcl
index 0e645c4..07f5868 100644
--- a/tools/index.tcl
+++ b/tools/index.tcl
@@ -4,7 +4,7 @@
# the man page conversion. It is used to extract information used to
# generate a table of contents and a keyword list.
#
-# 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/tools/installData.tcl b/tools/installData.tcl
index 4a3b1ee..644cf53 100644
--- a/tools/installData.tcl
+++ b/tools/installData.tcl
@@ -12,7 +12,7 @@ exec tclsh "$0" ${1+"$@"}
#
#----------------------------------------------------------------------
#
-# Copyright (c) 2004 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.
#----------------------------------------------------------------------
diff --git a/tools/installVfs.tcl b/tools/installVfs.tcl
new file mode 100644
index 0000000..699b00e
--- /dev/null
+++ b/tools/installVfs.tcl
@@ -0,0 +1,54 @@
+#!/bin/sh
+#\
+exec tclsh "$0" ${1+"$@"}
+
+#----------------------------------------------------------------------
+#
+# installVfs.tcl --
+#
+# This file wraps the /library file system around a binary
+#
+#----------------------------------------------------------------------
+#
+# 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.
+#----------------------------------------------------------------------
+
+proc mapDir {resultvar prefix filepath} {
+ upvar 1 $resultvar result
+ if {![info exists result]} {
+ set result {}
+ }
+ set queue [list $prefix $filepath]
+ while {[llength $queue]} {
+ set queue [lassign $queue qprefix qpath]
+ foreach ftail [glob -directory $qpath -nocomplain -tails *] {
+ set f [file join $qpath $ftail]
+ if {[file isdirectory $f]} {
+ if {$ftail eq "CVS"} continue
+ lappend queue [file join $qprefix $ftail] $f
+ } elseif {[file isfile $f]} {
+ if {$ftail eq "pkgIndex.tcl"} continue
+ if {$ftail eq "manifest.txt"} {
+ lappend result $f [file join $qprefix pkgIndex.tcl]
+ } else {
+ lappend result $f [file join $qprefix $ftail]
+ }
+ }
+ }
+ }
+}
+if {[llength $argv]<4} {
+ error "Usage: [file tail [info script]] IMG_OUTPUT IMG_INPUT PREFIX FILE_SYSTEM ?PREFIX FILE_SYSTEM?..."
+}
+
+set paths [lassign $argv DLL_OUTPUT DLL_INPUT]
+foreach {prefix fpath} $paths {
+ mapDir files $prefix [file normalize $fpath]
+}
+if {$DLL_INPUT != {}} {
+ zipfs lmkzip $DLL_OUTPUT $files
+} else {
+ zipfs lmkimg $DLL_OUTPUT $files {} $DLL_INPUT
+}
diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl
index 204783a..bbe5e4a 100755
--- a/tools/loadICU.tcl
+++ b/tools/loadICU.tcl
@@ -22,11 +22,14 @@
#
#----------------------------------------------------------------------
#
-# Copyright (c) 2004 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.
#----------------------------------------------------------------------
+puts stdout "TODO: output in UTF-8 in stead of using \\uhhhh sequences"
+exit; # Remove those two lines after modifying this tool.
+
# Calculate the Chinese numerals from zero to ninety-nine.
set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
new file mode 100644
index 0000000..17526e0
--- /dev/null
+++ b/tools/makeHeader.tcl
@@ -0,0 +1,182 @@
+# makeHeader.tcl --
+#
+# This script generates embeddable C source (in a .h file) from a .tcl
+# script.
+#
+# 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 8.6-
+
+namespace eval makeHeader {
+
+ ####################################################################
+ #
+ # mapSpecial --
+ # Transform a single line so that it is able to be put in a C string.
+ #
+ proc mapSpecial {str} {
+ # All Tcl metacharacters and key C backslash sequences
+ set MAP {
+ \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
+ \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
+ }
+ set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
+
+ subst [regsub -all {[^\x20-\x7E]} [string map $MAP $str] $XFORM]
+ }
+
+ ####################################################################
+ #
+ # compactLeadingSpaces --
+ # Converts the leading whitespace on a line into a more compact form.
+ #
+ proc compactLeadingSpaces {line} {
+ set line [string map {\t { }} [string trimright $line]]
+ if {[regexp {^[ ]+} $line spaces]} {
+ regsub -all {[ ]{4}} $spaces \t replace
+ set len [expr {[string length $spaces] - 1}]
+ set line [string replace $line 0 $len $replace]
+ }
+ return $line
+ }
+
+ ####################################################################
+ #
+ # processScript --
+ # Transform a whole sequence of lines with [mapSpecial].
+ #
+ proc processScript {scriptLines} {
+ lmap line $scriptLines {
+ # Skip blank and comment lines; they're there in the original
+ # sources so we don't need to copy them over.
+ if {[regexp {^\s*(?:#|$)} $line]} continue
+ format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
+ }
+ }
+
+ ####################################################################
+ #
+ # updateTemplate --
+ # Rewrite a template to contain the content from the input script.
+ #
+ proc updateTemplate {dataVar scriptLines} {
+ set BEGIN "*!BEGIN!: Do not edit below this line.*"
+ set END "*!END!: Do not edit above this line.*"
+
+ upvar 1 $dataVar data
+
+ set from [lsearch -glob $data $BEGIN]
+ set to [lsearch -glob $data $END]
+ if {$from < 0 || $to < 0 || $from >= $to} {
+ throw BAD "not a template"
+ }
+
+ set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
+ }
+
+ ####################################################################
+ #
+ # stripSurround --
+ # Removes the header and footer comments from a (line-split list of
+ # lines of) Tcl script code.
+ #
+ proc stripSurround {lines} {
+ set RE {^\s*$|^#}
+ set state 0
+ set lines [lmap line [lreverse $lines] {
+ if {!$state && [regexp $RE $line]} continue {
+ set state 1
+ set line
+ }
+ }]
+ return [lmap line [lreverse $lines] {
+ if {$state && [regexp $RE $line]} continue {
+ set state 0
+ set line
+ }
+ }]
+ }
+
+ ####################################################################
+ #
+ # updateTemplateFile --
+ # Rewrites a template file with the lines of the given script.
+ #
+ proc updateTemplateFile {headerFile scriptLines} {
+ set f [open $headerFile "r+"]
+ try {
+ set content [split [chan read -nonewline $f] "\n"]
+ updateTemplate content [stripSurround $scriptLines]
+ chan seek $f 0
+ chan puts $f [join $content \n]
+ chan truncate $f
+ } trap BAD msg {
+ # Add the filename to the message
+ throw BAD "${headerFile}: $msg"
+ } finally {
+ chan close $f
+ }
+ }
+
+ ####################################################################
+ #
+ # readScript --
+ # Read a script from a file and return its lines.
+ #
+ proc readScript {script} {
+ set f [open $script]
+ try {
+ chan configure $f -encoding utf-8
+ return [split [string trim [chan read $f]] "\n"]
+ } finally {
+ chan close $f
+ }
+ }
+
+ ####################################################################
+ #
+ # run --
+ # The main program of this script.
+ #
+ proc run {args} {
+ try {
+ if {[llength $args] != 2} {
+ throw ARGS "inputTclScript templateFile"
+ }
+ lassign $args inputTclScript templateFile
+
+ puts "Inserting $inputTclScript into $templateFile"
+ set scriptLines [readScript $inputTclScript]
+ updateTemplateFile $templateFile $scriptLines
+ exit 0
+ } trap ARGS msg {
+ puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\""
+ exit 2
+ } trap BAD msg {
+ puts stderr $msg
+ exit 1
+ } trap POSIX msg {
+ puts stderr $msg
+ exit 1
+ } on error {- opts} {
+ puts stderr [dict get $opts -errorinfo]
+ exit 3
+ }
+ }
+}
+
+########################################################################
+#
+# Launch the main program
+#
+if {[info script] eq $::argv0} {
+ makeHeader::run {*}$::argv
+}
+
+# Local-Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/tools/man2help.tcl b/tools/man2help.tcl
deleted file mode 100644
index 4a928d8..0000000
--- a/tools/man2help.tcl
+++ /dev/null
@@ -1,141 +0,0 @@
-# man2help.tcl --
-#
-# This file defines procedures that work in conjunction with the
-# man2tcl program to generate a Windows help file from Tcl manual
-# entries.
-#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-
-#
-# PASS 1
-#
-
-set man2tclprog [file join [file dirname [info script]] \
- man2tcl[file extension [info nameofexecutable]]]
-
-proc generateContents {basename version files} {
- global curID topics
- set curID 0
- foreach f $files {
- puts "Pass 1 -- $f"
- flush stdout
- doFile $f
- }
- set fd [open [file join [file dirname [info script]] $basename$version.cnt] w]
- fconfigure $fd -translation crlf
- puts $fd ":Base $basename$version.hlp"
- foreach package [getPackages] {
- foreach section [getSections $package] {
- if {![info exists lastSection]} {
- set lastSection {}
- }
- if {[string compare $lastSection $section]} {
- puts $fd "1 $section"
- }
- set lastSection $section
- set lastTopic {}
- foreach topic [getTopics $package $section] {
- if {[string compare $lastTopic $topic]} {
- set id $topics($package,$section,$topic)
- puts $fd "2 $topic=$id"
- set lastTopic $topic
- }
- }
- }
- }
- close $fd
-}
-
-
-#
-# PASS 2
-#
-
-proc generateHelp {basename files} {
- global curID topics keywords file id_keywords
- set curID 0
-
- foreach key [array names keywords] {
- foreach id $keywords($key) {
- lappend id_keywords($id) $key
- }
- }
-
- set file [open [file join [file dirname [info script]] $basename.rtf] w]
- fconfigure $file -translation crlf
- puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\{\\f1\\fmodern\\fcharset0\\fprq1 Courier New\;\}\}"
- foreach f $files {
- puts "Pass 2 -- $f"
- flush stdout
- initGlobals
- doFile $f
- pageBreak
- }
- puts $file "\}"
- close $file
-}
-
-# doFile --
-#
-# Given a file as argument, translate the file to a tcl script and
-# evaluate it.
-#
-# Arguments:
-# file - Name of file to translate.
-
-proc doFile {file} {
- global man2tclprog
- if {[catch {eval [exec $man2tclprog [glob $file]]} msg]} {
- global errorInfo
- puts stderr $msg
- puts "in"
- puts $errorInfo
- exit 1
- }
-}
-
-# doDir --
-#
-# Given a directory as argument, translate all the man pages in
-# that directory.
-#
-# Arguments:
-# dir - Name of the directory.
-
-proc doDir dir {
- puts "Generating man pages for $dir..."
- foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
- doFile $f
- }
-}
-
-# process command line arguments
-
-if {$argc < 3} {
- puts stderr "usage: $argv0 \[options\] projectName version manFiles..."
- exit 1
-}
-
-set arg 0
-
-if {![string compare [lindex $argv $arg] "-bitmap"]} {
- set bitmap [lindex $argv [incr arg]]
- incr arg
-}
-set baseName [lindex $argv $arg]
-set version [lindex $argv [incr arg]]
-set files {}
-foreach i [lrange $argv [incr arg] end] {
- set i [file join $i]
- if {[file isdir $i]} {
- foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
- lappend files $f
- }
- } elseif {[file exists $i]} {
- lappend files $i
- }
-}
-source [file join [file dirname [info script]] index.tcl]
-generateContents $baseName $version $files
-source [file join [file dirname [info script]] man2help2.tcl]
-generateHelp $baseName $files
diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl
deleted file mode 100644
index 655e55b..0000000
--- a/tools/man2help2.tcl
+++ /dev/null
@@ -1,1033 +0,0 @@
-# man2help2.tcl --
-#
-# This file defines procedures that are used during the second pass of
-# the man page conversion. It converts the man format input to rtf
-# form suitable for use by the Windows help compiler.
-#
-# Copyright (c) 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.
-
-# Global variables used by these scripts:
-#
-# state - state variable that controls action of text proc.
-#
-# topics - array indexed by (package,section,topic) with value
-# of topic ID.
-#
-# keywords - array indexed by keyword string with value of topic ID.
-#
-# curID - current topic ID, starts at 0 and is incremented for
-# each new topic file.
-#
-# curPkg - current package name (e.g. Tcl).
-#
-# curSect - current section title (e.g. "Tcl Built-In Commands").
-#
-
-# initGlobals --
-#
-# This procedure is invoked to set the initial values of all of the
-# global variables, before processing a man page.
-#
-# Arguments:
-# None.
-
-proc initGlobals {} {
- uplevel \#0 unset state
- global state chars
-
- set state(paragraphPending) 0
- set state(breakPending) 0
- set state(firstIndent) 0
- set state(leftIndent) 0
-
- set state(inTP) 0
- set state(paragraph) 0
- set state(textState) 0
- set state(curFont) ""
- set state(startCode) "{\\b "
- set state(startEmphasis) "{\\i "
- set state(endCode) "}"
- set state(endEmphasis) "}"
- set state(noFill) 0
- set state(charCnt) 0
- set state(offset) [getTwips 0.5i]
- set state(leftMargin) [getTwips 0.5i]
- set state(nestingLevel) 0
- set state(intl) 0
- set state(sb) 0
- setTabs 0.5i
-
-# set up international character table
-
- array set chars {
- o^ F4
- }
-}
-
-
-# beginFont --
-#
-# Arranges for future text to use a special font, rather than
-# the default paragraph font.
-#
-# Arguments:
-# font - Name of new font to use.
-
-proc beginFont {font} {
- global file state
-
- textSetup
- if {[string equal $state(curFont) $font]} {
- return
- }
- endFont
- puts -nonewline $file $state(start$font)
- set state(curFont) $font
-}
-
-
-# endFont --
-#
-# Reverts to the default font for the paragraph type.
-#
-# Arguments:
-# None.
-
-proc endFont {} {
- global state file
-
- if {[string compare $state(curFont) ""]} {
- puts -nonewline $file $state(end$state(curFont))
- set state(curFont) ""
- }
-}
-
-
-# textSetup --
-#
-# This procedure is called the first time that text is output for a
-# paragraph. It outputs the header information for the paragraph.
-#
-# Arguments:
-# None.
-
-proc textSetup {} {
- global file state
-
- if $state(breakPending) {
- puts $file "\\line"
- }
- if $state(paragraphPending) {
- puts $file [format "\\par\n\\pard\\fi%.0f\\li%.0f" \
- $state(firstIndent) $state(leftIndent)]
- foreach tab $state(tabs) {
- puts $file [format "\\tx%.0f" $tab]
- }
- set state(tabs) {}
- if {$state(sb)} {
- puts $file "\\sb$state(sb)"
- set state(sb) 0
- }
- }
- set state(breakPending) 0
- set state(paragraphPending) 0
-}
-
-
-# text --
-#
-# This procedure adds text to the current state(paragraph). If this is
-# the first text in the state(paragraph) then header information for the
-# state(paragraph) is output before the text.
-#
-# Arguments:
-# string - Text to output in the state(paragraph).
-
-proc text {string} {
- global file state chars
-
- textSetup
- set string [string map [list \
- "\\" "\\\\" \
- "\{" "\\\{" \
- "\}" "\\\}" \
- "\t" {\tab } \
- '' "\\rdblquote " \
- `` "\\ldblquote " \
- "\xB7" "\\bullet " \
- ] $string]
-
- # Check if this is the beginning of an international character string.
- # If so, look up the sequence in the chars table and substitute the
- # appropriate hex value.
-
- if {$state(intl)} {
- if {[regexp {^'([^']*)'} $string dummy ch]} {
- if {[info exists chars($ch)]} {
- regsub {^'[^']*'} $string "\\\\'$chars($ch)" string
- } else {
- puts stderr "Unknown international character '$ch'"
- }
- }
- set state(intl) 0
- }
-
- switch $state(textState) {
- REF {
- if {$state(inTP) == 0} {
- set string [insertRef $string]
- }
- }
- SEE {
- global topics curPkg curSect
- foreach i [split $string] {
- if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} {
- continue
- }
- if {![catch {set ref $topics($curPkg,$curSect,$i)} ]} {
- regsub $i $string [link $i $ref] string
- }
- }
- }
- KEY {
- return
- }
- }
- puts -nonewline $file "$string"
-}
-
-
-
-# insertRef --
-#
-# This procedure looks for a string in the cross reference table and
-# generates a hot-link to the appropriate topic. Tries to find the
-# nearest reference in the manual.
-#
-# Arguments:
-# string - Text to output in the state(paragraph).
-
-proc insertRef {string} {
- global NAME_file curPkg curSect topics curID
- set path {}
- set string [string trim $string]
- set ref {}
- if {[info exists topics($curPkg,$curSect,$string)]} {
- set ref $topics($curPkg,$curSect,$string)
- } else {
- set sites [array names topics "$curPkg,*,$string"]
- set count [llength $sites]
- if {$count > 0} {
- set ref $topics([lindex $sites 0])
- } else {
- set sites [array names topics "*,*,$string"]
- set count [llength $sites]
- if {$count > 0} {
- set ref $topics([lindex $sites 0])
- }
- }
- }
-
- if {($ref != "") && ($ref != $curID)} {
- set string [link $string $ref]
- }
- return $string
-}
-
-
-
-# macro --
-#
-# This procedure is invoked to process macro invocations that start
-# with "." (instead of ').
-#
-# Arguments:
-# name - The name of the macro (without the ".").
-# args - Any additional arguments to the macro.
-
-proc macro {name args} {
- global state file
- switch $name {
- AP {
- if {[llength $args] != 3 && [llength $args] != 2} {
- puts stderr "Bad .AP macro: .$name [join $args " "]"
- }
- newPara 3.75i -3.75i
- setTabs {1.25i 2.5i 3.75i}
- font B
- text [lindex $args 0]
- tab
- font I
- text [lindex $args 1]
- tab
- font R
- if {[llength $args] == 3} {
- text "([lindex $args 2])"
- }
- tab
- }
- AS {
- # next page and previous page
- }
- br {
- lineBreak
- }
- BS {}
- BE {}
- CE {
- puts -nonewline $::file "\\f0\\fs20 "
- set state(noFill) 0
- set state(breakPending) 0
- newPara ""
- set state(leftIndent) [expr {$state(leftIndent) - $state(offset)}]
- set state(sb) 80
- }
- CS {
- # code section
- set state(noFill) 1
- newPara ""
- set state(leftIndent) [expr {$state(leftIndent) + $state(offset)}]
- set state(sb) 80
- puts -nonewline $::file "\\f1\\fs18 "
- }
- DE {
- set state(noFill) 0
- decrNestingLevel
- newPara 0i
- }
- DS {
- set state(noFill) 1
- incrNestingLevel
- newPara 0i
- }
- fi {
- set state(noFill) 0
- }
- IP {
- IPmacro $args
- }
- LP {
- newPara 0i
- set state(sb) 80
- }
- ne {
- }
- nf {
- set state(noFill) 1
- }
- OP {
- if {[llength $args] != 3} {
- puts stderr "Bad .OP macro: .$name [join $args " "]"
- }
- set state(nestingLevel) 0
- newPara 0i
- set state(sb) 120
- setTabs 4c
- text "Command-Line Name:"
- tab
- font B
- set x [lindex $args 0]
- regsub -all {\\-} $x - x
- text $x
- lineBreak
- font R
- text "Database Name:"
- tab
- font B
- text [lindex $args 1]
- lineBreak
- font R
- text "Database Class:"
- tab
- font B
- text [lindex $args 2]
- font R
- set state(inTP) 0
- newPara 0.5i
- set state(sb) 80
- }
- PP {
- newPara 0i
- set state(sb) 120
- }
- RE {
- decrNestingLevel
- }
- RS {
- incrNestingLevel
- }
- SE {
- font R
- set state(noFill) 0
- set state(nestingLevel) 0
- newPara 0i
- text "See the "
- font B
- set temp $state(textState)
- set state(textState) REF
- text options
- set state(textState) $temp
- font R
- text " manual entry for detailed descriptions of the above options."
- }
- SH {
- SHmacro $args
- }
- SS {
- SHmacro $args subsection
- }
- SO {
- SHmacro "STANDARD OPTIONS"
- set state(nestingLevel) 0
- newPara 0i
- setTabs {4c 8c 12c}
- font B
- set state(noFill) 1
- }
- so {
- if {$args ne "man.macros"} {
- puts stderr "Unknown macro: .$name [join $args " "]"
- }
- }
- sp { ;# needs work
- if {$args eq ""} {
- set count 1
- } else {
- set count [lindex $args 0]
- }
- while {$count > 0} {
- lineBreak
- incr count -1
- }
- }
- ta {
- setTabs $args
- }
- TH {
- THmacro $args
- }
- TP {
- TPmacro $args
- }
- UL { ;# underline
- puts -nonewline $file "{\\ul "
- text [lindex $args 0]
- puts -nonewline $file "}"
- if {[llength $args] == 2} {
- text [lindex $args 1]
- }
- }
- VE {}
- VS {}
- QW {
- formattedText "``[lindex $args 0]''[lindex $args 1] "
- }
- MT {
- text "``'' "
- }
- PQ {
- formattedText \
- "(``[lindex $args 0]''[lindex $args 1])[lindex $args 2] "
- }
- QR {
- formattedText "``[lindex $args 0]"
- dash
- formattedText "[lindex $args 1]''[lindex $args 2] "
- }
- default {
- puts stderr "Unknown macro: .$name [join $args " "]"
- }
- }
-}
-
-
-# link --
-#
-# This procedure returns the string for a hot link to a different
-# context location.
-#
-# Arguments:
-# label - String to display in hot-spot.
-# id - Context string to jump to.
-
-proc link {label id} {
- return "{\\uldb $label}{\\v $id}"
-}
-
-
-# font --
-#
-# This procedure is invoked to handle font changes in the text
-# being output.
-#
-# Arguments:
-# type - Type of font: R, I, B, or S.
-
-proc font {type} {
- global state
- switch $type {
- P -
- R {
- endFont
- if {$state(textState) eq "REF"} {
- set state(textState) INSERT
- }
- }
- C -
- B {
- beginFont Code
- if {$state(textState) eq "INSERT"} {
- set state(textState) REF
- }
- }
- I {
- beginFont Emphasis
- }
- S {
- }
- default {
- puts stderr "Unknown font: $type"
- }
- }
-}
-
-
-
-# formattedText --
-#
-# Insert a text string that may also have \fB-style font changes
-# and a few other backslash sequences in it.
-#
-# Arguments:
-# text - Text to insert.
-
-proc formattedText {text} {
- global chars
-
- while {$text ne ""} {
- set index [string first \\ $text]
- if {$index < 0} {
- text $text
- return
- }
- text [string range $text 0 [expr {$index-1}]]
- set c [string index $text [expr {$index+1}]]
- switch -- $c {
- f {
- font [string index $text [expr {$index+2}]]
- set text [string range $text [expr {$index+3}] end]
- }
- e {
- text "\\"
- set text [string range $text [expr {$index+2}] end]
- }
- - {
- dash
- set text [string range $text [expr {$index+2}] end]
- }
- & - | {
- set text [string range $text [expr {$index+2}] end]
- }
- ( {
- char [string range $text $index [expr {$index+3}]]
- set text [string range $text [expr {$index+4}] end]
- }
- default {
- puts stderr "Unknown sequence: \\$c"
- set text [string range $text [expr {$index+2}] end]
- }
- }
- }
-}
-
-
-# dash --
-#
-# This procedure is invoked to handle dash characters ("\-" in
-# troff). It outputs a special dash character.
-#
-# Arguments:
-# None.
-
-proc dash {} {
- global state
- if {[string equal $state(textState) "NAME"]} {
- set state(textState) 0
- }
- text "-"
-}
-
-
-# tab --
-#
-# This procedure is invoked to handle tabs in the troff input.
-# Right now it does nothing.
-#
-# Arguments:
-# None.
-
-proc tab {} {
- global file
-
- textSetup
- puts -nonewline $file "\\tab "
-}
-
-
-# setTabs --
-#
-# This procedure handles the ".ta" macro, which sets tab stops.
-#
-# Arguments:
-# tabList - List of tab stops in *roff format
-
-proc setTabs {tabList} {
- global file state
-
- set state(tabs) {}
- foreach arg $tabList {
- if {[string match +* $arg]} {
- set relativeTo [lindex $state(tabs) end]
- set arg [string range $arg 1 end]
- } else {
- # Local left margin
- set relativeTo [expr {$state(leftMargin) \
- + ($state(offset) * $state(nestingLevel))}]
- }
- if {[regexp {^\\w'([^']*)'u$} $arg -> submatch]} {
- # Magic factor!
- set distance [expr {[string length $submatch] * 86.4}]
- } else {
- set distance [getTwips $arg]
- }
- lappend state(tabs) [expr {round($distance + $relativeTo)}]
- }
-}
-
-
-# lineBreak --
-#
-# Generates a line break in the HTML output.
-#
-# Arguments:
-# None.
-
-proc lineBreak {} {
- global state
- textSetup
- set state(breakPending) 1
-}
-
-
-
-# newline --
-#
-# This procedure is invoked to handle newlines in the troff input.
-# It outputs either a space character or a newline character, depending
-# on fill mode.
-#
-# Arguments:
-# None.
-
-proc newline {} {
- global state
-
- if {$state(inTP)} {
- set state(inTP) 0
- lineBreak
- } elseif {$state(noFill)} {
- lineBreak
- } else {
- text " "
- }
-}
-
-
-# pageBreak --
-#
-# This procedure is invoked to generate a page break.
-#
-# Arguments:
-# None.
-
-proc pageBreak {} {
- global file curVer
- if {[string equal $curVer ""]} {
- puts $file {\page}
- } else {
- puts $file {\par}
- puts $file {\pard\sb400\qc}
- puts $file "Last change: $curVer\\page"
- }
-}
-
-
-# char --
-#
-# This procedure is called to handle a special character.
-#
-# Arguments:
-# name - Special character named in troff \x or \(xx construct.
-
-proc char {name} {
- global file state
-
- switch -exact $name {
- {\o} {
- set state(intl) 1
- }
- {\ } {
- textSetup
- puts -nonewline $file " "
- }
- {\0} {
- textSetup
- puts -nonewline $file " \\emspace "
- }
- {\\} - {\e} {
- textSetup
- puts -nonewline $file "\\\\"
- }
- {\(+-} {
- textSetup
- puts -nonewline $file "\\'b1 "
- }
- {\%} - {\|} {
- }
- {\(->} {
- textSetup
- puts -nonewline $file "->"
- }
- {\(bu} {
- textSetup
- puts -nonewline $file "\\bullet "
- }
- {\(co} {
- textSetup
- puts -nonewline $file "\\'a9 "
- }
- {\(mi} {
- textSetup
- puts -nonewline $file "-"
- }
- {\(mu} {
- textSetup
- puts -nonewline $file "\\'d7 "
- }
- {\(em} - {\(en} {
- textSetup
- puts -nonewline $file "-"
- }
- {\(fm} {
- textSetup
- puts -nonewline $file "\\'27 "
- }
- default {
- puts stderr "Unknown character: $name"
- }
- }
-}
-
-
-# macro2 --
-#
-# This procedure handles macros that are invoked with a leading "'"
-# character instead of space. Right now it just generates an
-# error diagnostic.
-#
-# Arguments:
-# name - The name of the macro (without the ".").
-# args - Any additional arguments to the macro.
-
-proc macro2 {name args} {
- puts stderr "Unknown macro: '$name [join $args " "]"
-}
-
-
-
-# SHmacro --
-#
-# Subsection head; handles the .SH and .SS macros.
-#
-# Arguments:
-# name - Section name.
-
-proc SHmacro {argList {style section}} {
- global file state
-
- set args [join $argList " "]
- if {[llength $argList] < 1} {
- puts stderr "Bad .SH macro: .SH $args"
- }
-
- # control what the text proc does with text
-
- switch $args {
- NAME {set state(textState) NAME}
- DESCRIPTION {set state(textState) INSERT}
- INTRODUCTION {set state(textState) INSERT}
- "WIDGET-SPECIFIC OPTIONS" {set state(textState) INSERT}
- "SEE ALSO" {set state(textState) SEE}
- KEYWORDS {set state(textState) KEY; return}
- }
-
- if {$state(breakPending) != -1} {
- set state(breakPending) 1
- } else {
- set state(breakPending) 0
- }
- set state(noFill) 0
- if {[string compare "subsection" $style] == 0} {
- nextPara .25i
- } else {
- nextPara 0i
- }
- font B
- text $args
- font R
- nextPara .5i
-}
-
-# IPmacro --
-#
-# This procedure is invoked to handle ".IP" macros, which may take any
-# of the following forms:
-#
-# .IP [1] Translate to a "1Step" state(paragraph).
-# .IP [x] (x > 1) Translate to a "Step" state(paragraph).
-# .IP Translate to a "Bullet" state(paragraph).
-# .IP text count Translate to a FirstBody state(paragraph) with special
-# indent and tab stop based on "count", and tab after
-# "text".
-#
-# Arguments:
-# argList - List of arguments to the .IP macro.
-#
-# HTML limitations: 'count' in '.IP text count' is ignored.
-
-proc IPmacro {argList} {
- global file state
-
- set length [llength $argList]
- foreach {text indent} $argList break
- if {$length > 2} {
- puts stderr "Bad .IP macro: .IP [join $argList " "]"
- }
-
- if {$length == 0} {
- set text {\(bu}
- set indent 5
- } elseif {$length == 1} {
- set indent 5
- }
- if {$text == {\(bu}} {
- set text "\xB7"
- }
-
- set tab [expr {$indent * 0.1}]i
- newPara $tab -$tab
- set state(sb) 80
- setTabs $tab
- formattedText $text
- tab
-}
-
-# TPmacro --
-#
-# This procedure is invoked to handle ".TP" macros, which may take any
-# of the following forms:
-#
-# .TP x Translate to an state(indent)ed state(paragraph) with the
-# specified state(indent) (in 100 twip units).
-# .TP Translate to an state(indent)ed state(paragraph) with
-# default state(indent).
-#
-# Arguments:
-# argList - List of arguments to the .IP macro.
-#
-# HTML limitations: 'x' in '.TP x' is ignored.
-
-proc TPmacro {argList} {
- global state
- set length [llength $argList]
- if {$length == 0} {
- set val 0.5i
- } else {
- set val [expr {([lindex $argList 0] * 100.0)/1440}]i
- }
- newPara $val -$val
- setTabs $val
- set state(inTP) 1
- set state(sb) 120
-}
-
-
-# THmacro --
-#
-# This procedure handles the .TH macro. It generates the non-scrolling
-# header section for a given man page, and enters information into the
-# table of contents. The .TH macro has the following form:
-#
-# .TH name section date footer header
-#
-# Arguments:
-# argList - List of arguments to the .TH macro.
-
-proc THmacro {argList} {
- global file curPkg curSect curID id_keywords state curVer bitmap
-
- if {[llength $argList] != 5} {
- set args [join $argList " "]
- puts stderr "Bad .TH macro: .TH $args"
- }
- incr curID
- set name [lindex $argList 0] ;# Tcl_UpVar
- set page [lindex $argList 1] ;# 3
- set curVer [lindex $argList 2] ;# 7.4
- set curPkg [lindex $argList 3] ;# Tcl
- set curSect [lindex $argList 4] ;# {Tcl Library Procedures}
-
- regsub -all {\\ } $curSect { } curSect ;# Clean up for [incr\ Tcl]
-
- puts $file "#{\\footnote $curID}" ;# Context string
- puts $file "\${\\footnote $name}" ;# Topic title
- set browse "${curSect}${name}"
- regsub -all {[ _-]} $browse {} browse
- puts $file "+{\\footnote $browse}" ;# Browse sequence
-
- # Suppress duplicates
- foreach i $id_keywords($curID) {
- set keys($i) 1
- }
- foreach i [array names keys] {
- set i [string trim $i]
- if {[string length $i] > 0} {
- puts $file "K{\\footnote $i}" ;# Keyword strings
- }
- }
- unset keys
- puts $file "\\pard\\tx3000\\sb100\\sa100\\fs24\\keepn"
- font B
- text $name
- tab
- text $curSect
- font R
- if {[info exists bitmap]} {
- # a right justified bitmap
- puts $file "\\\{bmrt $bitmap\\\}"
- }
- puts $file "\\fs20"
- set state(breakPending) -1
-}
-
-# nextPara --
-#
-# Set the indents for a new paragraph, and start a paragraph break
-#
-# Arguments:
-# leftIndent - The new left margin for body lines.
-# firstIndent - The offset from the left margin for the first line.
-
-proc nextPara {leftIndent {firstIndent 0i}} {
- global state
- set state(leftIndent) [getTwips $leftIndent]
- set state(firstIndent) [getTwips $firstIndent]
- set state(paragraphPending) 1
-}
-
-
-# newPara --
-#
-# This procedure sets the left and hanging state(indent)s for a line.
-# State(Indent)s are specified in units of inches or centimeters, and are
-# relative to the current nesting level and left margin.
-#
-# Arguments:
-# leftState(Indent) - The new left margin for lines after the first.
-# firstState(Indent) - The new left margin for the first line of a state(paragraph).
-
-proc newPara {leftIndent {firstIndent 0i}} {
- global state file
- if $state(paragraph) {
- puts -nonewline $file "\\line\n"
- }
- if {$leftIndent ne ""} {
- set state(leftIndent) [expr {$state(leftMargin) \
- + ($state(offset) * $state(nestingLevel)) \
- + [getTwips $leftIndent]}]
- }
- set state(firstIndent) [getTwips $firstIndent]
- set state(paragraphPending) 1
-}
-
-
-# getTwips --
-#
-# This procedure converts a distance in inches or centimeters into
-# twips (1/1440 of an inch).
-#
-# Arguments:
-# arg - A number followed by "i" or "c"
-
-proc getTwips {arg} {
- if {[scan $arg "%f%s" distance units] != 2} {
- puts stderr "bad distance \"$arg\""
- return 0
- }
- if {[string length $units] > 1} {
- puts stderr "additional characters after unit \"$arg\""
- set units [string index $units 0]
- }
- switch -- $units {
- c {
- set distance [expr {$distance * 567}]
- }
- i {
- set distance [expr {$distance * 1440}]
- }
- default {
- puts stderr "bad units in distance \"$arg\""
- return 0
- }
- }
- return $distance
-}
-
-# incrNestingLevel --
-#
-# This procedure does the work of the .RS macro, which increments
-# the number of state(indent)ations that affect things like .PP.
-#
-# Arguments:
-# None.
-
-proc incrNestingLevel {} {
- global state
-
- incr state(nestingLevel)
- set oldp $state(paragraph)
- set state(paragraph) 0
- newPara 0i
- set state(paragraph) $oldp
-}
-
-# decrNestingLevel --
-#
-# This procedure does the work of the .RE macro, which decrements
-# the number of indentations that affect things like .PP.
-#
-# Arguments:
-# None.
-
-proc decrNestingLevel {} {
- global state
-
- if {$state(nestingLevel) == 0} {
- puts stderr "Nesting level decremented below 0"
- } else {
- incr state(nestingLevel) -1
- }
-}
diff --git a/tools/man2html.tcl b/tools/man2html.tcl
deleted file mode 100644
index 28a6751..0000000
--- a/tools/man2html.tcl
+++ /dev/null
@@ -1,185 +0,0 @@
-#!/bin/sh
-# \
-exec tclsh "$0" ${1+"$@"}
-
-# man2html.tcl --
-#
-# This file contains procedures that work in conjunction with the
-# man2tcl program to generate a HTML files from Tcl manual entries.
-#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-
-
-# sarray -
-#
-# Save an array to a file so that it can be sourced.
-#
-# Arguments:
-# file - Name of the output file
-# args - Name of the arrays to save
-#
-proc sarray {file args} {
- set file [open $file w]
- foreach a $args {
- upvar $a array
- if {![array exists array]} {
- puts "sarray: \"$a\" isn't an array"
- break
- }
-
- foreach name [lsort [array names array]] {
- regsub -all " " $name "\\ " name1
- puts $file "set ${a}($name1) \{$array($name)\}"
- }
- }
- close $file
-}
-
-
-# footer --
-#
-# Builds footer info for HTML pages
-#
-# Arguments:
-# packages - List of packages to link to.
-
-proc footer {packages} {
- lappend f "<HR>"
- set h {[}
- foreach package $packages {
- lappend h "<A HREF=\"../$package/contents.html\">$package</A>"
- lappend h "|"
- }
- lappend f [join [lreplace $h end end {]} ] " "]
- lappend f "<HR>"
- lappend f "<PRE>Copyright &#169; 1989-1994 The Regents of the University of California."
- lappend f "Copyright &#169; 1994-1996 Sun Microsystems, Inc."
- lappend f "</PRE>"
- return [join $f "\n"]
-}
-
-
-# doDir --
-#
-# Given a directory as argument, translate all the man pages in
-# that directory.
-#
-# Arguments:
-# dir - Name of the directory.
-
-proc doDir dir {
- foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
- do $f ;# defined in man2html1.tcl & man2html2.tcl
- }
-}
-
-
-# main --
-#
-# Main code for converting Tcl manual pages to HTML.
-#
-# Arguments:
-# argv - List of arguments to this script.
-
-proc main {argv} {
- global html_dir
- # Global vars used in man2html1.tcl and man2html2.tcl
- global NAME_file KEY_file lib state curFile file inDT textState nestStk
- global curFont fontStart fontEnd noFillCount footer
-
- if {[llength $argv] < 2} {
- puts stderr "usage: $::argv0 html_dir tcl_dir packages..."
- puts stderr "usage: $::argv0 -clean html_dir"
- exit 1
- }
-
- if {[lindex $argv 0] eq "-clean"} {
- set html_dir [lindex $argv 1]
- puts -nonewline "recursively remove: $html_dir? "
- flush stdout
- if {[gets stdin] eq "y"} {
- puts "removing: $html_dir"
- file delete -force $html_dir
- }
- exit 0
- }
-
- set html_dir [lindex $argv 0]
- set tcl_dir [lindex $argv 1]
- set packages [lrange $argv 2 end]
- set homeDir [file dirname [info script]]
-
- #### need to add glob capability to packages ####
-
- # make sure there are doc directories for each package
-
- foreach i $packages {
- if {![file exists $tcl_dir/$i/doc]} {
- puts stderr "Error: doc directory for package $i is missing"
- exit 1
- }
- if {![file isdirectory $tcl_dir/$i/doc]} {
- puts stderr "Error: $tcl_dir/$i/doc is not a directory"
- exit 1
- }
- }
-
- # we want to start with a clean sheet
-
- if {[file exists $html_dir]} {
- puts stderr "Error: HTML directory already exists"
- exit 1
- } else {
- file mkdir $html_dir
- }
-
- set footer [footer $packages]
-
- # make the hyperlink arrays and contents.html for all packages
-
- foreach package $packages {
- file mkdir $html_dir/$package
-
- # build hyperlink database arrays: NAME_file and KEY_file
- #
- puts "\nScanning man pages in $tcl_dir/$package/doc..."
- uplevel \#0 [list source $homeDir/man2html1.tcl]
-
- doDir $tcl_dir/$package/doc
-
- # clean up the NAME_file and KEY_file database arrays
- #
- catch {unset KEY_file()}
- foreach name [lsort [array names NAME_file]] {
- set file_name $NAME_file($name)
- if {[llength $file_name] > 1} {
- set file_name [lsort $file_name]
- puts "Warning: '$name' multiply defined in: $file_name;\
- using last"
- set NAME_file($name) [lindex $file_name end]
- }
- }
- # sarray $html_dir/$package/xref.tcl NAME_file KEY_file
-
- # build the contents file from NAME_file
- #
- puts "\nGenerating contents.html for $package"
- doContents $html_dir/$package/contents.html $lib ;# defined in man2html1.tcl
-
- # now translate the man pages to HTML pages
- #
- uplevel \#0 [list source $homeDir/man2html2.tcl]
- puts "\nBuilding html pages from man pages in $tcl_dir/$package/doc..."
- doDir $tcl_dir/$package/doc
-
- unset NAME_file
- }
-}
-
-
-if [catch { main $argv } result] {
- global errorInfo
- puts stderr $result
- puts stderr "in"
- puts stderr $errorInfo
-}
diff --git a/tools/man2html1.tcl b/tools/man2html1.tcl
deleted file mode 100644
index 7a789f7..0000000
--- a/tools/man2html1.tcl
+++ /dev/null
@@ -1,258 +0,0 @@
-# man2html1.tcl --
-#
-# This file defines procedures that are used during the first pass of the
-# man page to html conversion process. It is sourced by h.tcl.
-#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-
-# Global variables used by these scripts:
-#
-# state - state variable that controls action of text proc.
-#
-# curFile - tail of current man page.
-#
-# file - file pointer; for both xref.tcl and contents.html
-#
-# NAME_file - array indexed by NAME and containing file names used
-# for hyperlinks.
-#
-# KEY_file - array indexed by KEYWORD and containing file names used
-# for hyperlinks.
-#
-# lib - contains package name. Used to label section in contents.html
-#
-# inDT - in dictionary term.
-
-
-# text --
-#
-# This procedure adds entries to the hypertext arrays NAME_file
-# and KEY_file.
-#
-# DT: might do this: if first word of $dt matches $name and [llength $name==1]
-# and [llength $dt > 1], then add to NAME_file.
-#
-# Arguments:
-# string - Text to index.
-
-proc text string {
- global state curFile NAME_file KEY_file inDT
-
- switch $state {
- NAME {
- foreach i [split $string ","] {
- lappend NAME_file([string trim $i]) $curFile
- }
- }
- KEY {
- foreach i [split $string ","] {
- lappend KEY_file([string trim $i]) $curFile
- }
- }
- DT -
- OFF -
- DASH {}
- default {
- puts stderr "text: unknown state: $state"
- }
- }
-}
-
-
-# macro --
-#
-# This procedure is invoked to process macro invocations that start
-# with "." (instead of ').
-#
-# Arguments:
-# name - The name of the macro (without the ".").
-# args - Any additional arguments to the macro.
-
-proc macro {name args} {
- switch $name {
- SH - SS {
- global state
-
- switch $args {
- NAME {
- if {$state eq "INIT"} {
- set state NAME
- }
- }
- DESCRIPTION {set state DT}
- INTRODUCTION {set state DT}
- KEYWORDS {set state KEY}
- default {set state OFF}
- }
-
- }
- TP {
- global inDT
- set inDT 1
- }
- TH {
- global lib state inDT
- set inDT 0
- set state INIT
- if {[llength $args] != 5} {
- set args [join $args " "]
- puts stderr "Bad .TH macro: .$name $args"
- }
- set lib [lindex $args 3] ;# Tcl or Tk
- }
- }
-}
-
-
-# dash --
-#
-# This procedure is invoked to handle dash characters ("\-" in
-# troff). It only function in pass1 is to terminate the NAME state.
-#
-# Arguments:
-# None.
-
-proc dash {} {
- global state
- if {$state eq "NAME"} {
- set state DASH
- }
-}
-
-
-# newline --
-#
-# This procedure is invoked to handle newlines in the troff input.
-# It's only purpose is to terminate a DT (dictionary term).
-#
-# Arguments:
-# None.
-
-proc newline {} {
- global inDT
- set inDT 0
-}
-
-
-# initGlobals, tab, font, char, macro2 --
-#
-# These procedures do nothing during the first pass.
-#
-# Arguments:
-# None.
-
-proc initGlobals {} {}
-proc tab {} {}
-proc font type {}
-proc char name {}
-proc macro2 {name args} {}
-
-
-# doListing --
-#
-# Writes an ls like list to a file. Searches NAME_file for entries
-# that match the input pattern.
-#
-# Arguments:
-# file - Output file pointer.
-# pattern - glob style match pattern
-
-proc doListing {file pattern} {
- global NAME_file
-
- set max_len 0
- foreach name [lsort [array names NAME_file]] {
- set ref $NAME_file($name)
- if [string match $pattern $ref] {
- lappend type $name
- if {[string length $name] > $max_len} {
- set max_len [string length $name]
- }
- }
- }
- if [catch {llength $type} ] {
- puts stderr " doListing: no names matched pattern ($pattern)"
- return
- }
- incr max_len
- set ncols [expr {90/$max_len}]
- set nrows [expr {int(ceil([llength $type] / double($ncols)))} ]
-
-# ? max_len ncols nrows
-
- set index 0
- foreach f $type {
- lappend row([expr {$index % $nrows}]) $f
- incr index
- }
-
- puts -nonewline $file "<PRE>"
- for {set i 0} {$i<$nrows} {incr i} {
- foreach name $row($i) {
- set str [format "%-*s" $max_len $name]
- regsub $name $str "<A HREF=\"$NAME_file($name).html\">$name</A>" str
- puts -nonewline $file $str
- }
- puts $file {}
- }
- puts $file "</PRE>"
-}
-
-
-# doContents --
-#
-# Generates a HTML contents file using the NAME_file array
-# as its input database.
-#
-# Arguments:
-# file - name of the contents file.
-# packageName - string used in the title and sub-heads of the HTML
-# page. Normally name of the package without version
-# numbers.
-
-proc doContents {file packageName} {
- global footer
-
- set file [open $file w]
-
- puts $file "<HTML><HEAD><TITLE>$packageName Manual</TITLE></HEAD><BODY>"
- puts $file "<H3>$packageName</H3>"
- doListing $file "*.1"
-
- puts $file "<HR><H3>$packageName Commands</H3>"
- doListing $file "*.n"
-
- puts $file "<HR><H3>$packageName Library</H3>"
- doListing $file "*.3"
-
- puts $file $footer
- puts $file "</BODY></HTML>"
- close $file
-}
-
-
-# do --
-#
-# This is the toplevel procedure that searches a man page
-# for hypertext links. It builds a data base consisting of
-# two arrays: NAME_file and KEY file. It runs the man2tcl
-# program to turn the man page into a script, then it evals
-# that script.
-#
-# Arguments:
-# fileName - Name of the file to scan.
-
-proc do fileName {
- global curFile
- set curFile [file tail $fileName]
- set file stdout
- puts " Pass 1 -- $fileName"
- flush stdout
- if [catch {eval [exec man2tcl [glob $fileName]]} msg] {
- global errorInfo
- puts stderr $msg
- puts "in"
- puts $errorInfo
- exit 1
- }
-}
diff --git a/tools/man2html2.tcl b/tools/man2html2.tcl
deleted file mode 100644
index 19d6ce0..0000000
--- a/tools/man2html2.tcl
+++ /dev/null
@@ -1,927 +0,0 @@
-##############################################################################
-# man2html2.tcl --
-#
-# This file defines procedures that are used during the second pass of the man
-# page to html conversion process. It is sourced by man2html.tcl.
-#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-
-# Global variables used by these scripts:
-#
-# NAME_file - array indexed by NAME and containing file names used for
-# hyperlinks.
-#
-# textState - state variable defining action of 'text' proc.
-#
-# nestStk - stack oriented list containing currently active HTML tags (UL,
-# OL, DL). Local to 'nest' proc.
-#
-# inDT - set by 'TPmacro', cleared by 'newline'. Used to insert the
-# tag while in a dictionary list <DL>.
-#
-# curFont - Name of special font that is currently in use. Null means the
-# default paragraph font is being used.
-#
-# file - Where to output the generated HTML.
-#
-# fontStart - Array to map font names to starting sequences.
-#
-# fontEnd - Array to map font names to ending sequences.
-#
-# noFillCount - Non-zero means don't fill the next $noFillCount lines: force a
-# line break at each newline. Zero means filling is enabled, so
-# don't output line breaks for each newline.
-#
-# footer - info inserted at bottom of each page. Normally read from the
-# xref.tcl file
-
-##############################################################################
-# initGlobals --
-#
-# This procedure is invoked to set the initial values of all of the global
-# variables, before processing a man page.
-#
-# Arguments:
-# None.
-
-proc initGlobals {} {
- global file noFillCount textState
- global fontStart fontEnd curFont inPRE charCnt inTable
-
- nest init
- set inPRE 0
- set inTable 0
- set textState 0
- set curFont ""
- set fontStart(Code) "<B>"
- set fontStart(Emphasis) "<I>"
- set fontEnd(Code) "</B>"
- set fontEnd(Emphasis) "</I>"
- set noFillCount 0
- set charCnt 0
- setTabs 0.5i
-}
-
-##############################################################################
-# beginFont --
-#
-# Arranges for future text to use a special font, rather than the default
-# paragraph font.
-#
-# Arguments:
-# font - Name of new font to use.
-
-proc beginFont font {
- global curFont file fontStart
-
- if {$curFont eq $font} {
- return
- }
- endFont
- puts -nonewline $file $fontStart($font)
- set curFont $font
-}
-
-##############################################################################
-# endFont --
-#
-# Reverts to the default font for the paragraph type.
-#
-# Arguments:
-# None.
-
-proc endFont {} {
- global curFont file fontEnd
-
- if {$curFont ne ""} {
- puts -nonewline $file $fontEnd($curFont)
- set curFont ""
- }
-}
-
-##############################################################################
-# text --
-#
-# This procedure adds text to the current paragraph. If this is the first text
-# in the paragraph then header information for the paragraph is output before
-# the text.
-#
-# Arguments:
-# string - Text to output in the paragraph.
-
-proc text string {
- global file textState inDT charCnt inTable
-
- set pos [string first "\t" $string]
- if {$pos >= 0} {
- text [string range $string 0 [expr {$pos-1}]]
- tab
- text [string range $string [expr {$pos+1}] end]
- return
- }
- if {$inTable} {
- if {$inTable == 1} {
- puts -nonewline $file <TR>
- set inTable 2
- }
- puts -nonewline $file <TD>
- }
- incr charCnt [string length $string]
- regsub -all {&} $string {\&amp;} string
- regsub -all {<} $string {\&lt;} string
- regsub -all {>} $string {\&gt;} string
- regsub -all \" $string {\&quot;} string
- switch -exact -- $textState {
- REF {
- if {$inDT eq ""} {
- set string [insertRef $string]
- }
- }
- SEE {
- global NAME_file
- foreach i [split $string] {
- if {![regexp -nocase {^[a-z_]+} [string trim $i] i]} {
-# puts "Warning: $i in SEE ALSO not found"
- continue
- }
- if {![catch { set ref $NAME_file($i) }]} {
- regsub $i $string "<A HREF=\"$ref.html\">$i</A>" string
- }
- }
- }
- }
- puts -nonewline $file "$string"
- if {$inTable} {
- puts -nonewline $file </TD>
- }
-}
-
-##############################################################################
-# insertRef --
-#
-# Arguments:
-# string - Text to output in the paragraph.
-
-proc insertRef string {
- global NAME_file self
- set path {}
- if {![catch { set ref $NAME_file([string trim $string]) }]} {
- if {"$ref.html" ne $self} {
- set string "<A HREF=\"${path}$ref.html\">$string</A>"
-# puts "insertRef: $self $ref.html ---$string--"
- }
- }
- return $string
-}
-
-##############################################################################
-# macro --
-#
-# This procedure is invoked to process macro invocations that start with "."
-# (instead of ').
-#
-# Arguments:
-# name - The name of the macro (without the ".").
-# args - Any additional arguments to the macro.
-
-proc macro {name args} {
- switch $name {
- AP {
- if {[llength $args] != 3} {
- puts stderr "Bad .AP macro: .$name [join $args " "]"
- }
- setTabs {1.25i 2.5i 3.75i}
- TPmacro {}
- font B
- text "[lindex $args 0] "
- font I
- text "[lindex $args 1]"
- font R
- text " ([lindex $args 2])"
- newline
- }
- AS {} ;# next page and previous page
- br {
- lineBreak
- }
- BS {}
- BE {}
- CE {
- global file noFillCount inPRE
- puts $file </PRE></BLOCKQUOTE>
- set inPRE 0
- }
- CS { ;# code section
- global file noFillCount inPRE
- puts -nonewline $file <BLOCKQUOTE><PRE>
- set inPRE 1
- }
- DE {
- global file noFillCount inTable
- puts $file </TABLE></BLOCKQUOTE>
- set inTable 0
- set noFillCount 0
- }
- DS {
- global file noFillCount inTable
- puts -nonewline $file {<BLOCKQUOTE><TABLE BORDER="0">}
- set noFillCount 10000000
- set inTable 1
- }
- fi {
- global noFillCount
- set noFillCount 0
- }
- IP {
- IPmacro $args
- }
- LP {
- nest decr
- nest incr
- newPara
- }
- ne {
- }
- nf {
- global noFillCount
- set noFillCount 1000000
- }
- OP {
- global inDT file inPRE
- if {[llength $args] != 3} {
- puts stderr "Bad .OP macro: .$name [join $args " "]"
- }
- nest para DL DT
- set inPRE 1
- puts -nonewline $file <PRE>
- setTabs 4c
- text "Command-Line Name:"
- tab
- font B
- set x [lindex $args 0]
- regsub -all {\\-} $x - x
- text $x
- newline
- font R
- text "Database Name:"
- tab
- font B
- text [lindex $args 1]
- newline
- font R
- text "Database Class:"
- tab
- font B
- text [lindex $args 2]
- font R
- puts -nonewline $file </PRE>
- set inDT "\n<DD>" ;# next newline writes inDT
- set inPRE 0
- newline
- }
- PP {
- nest decr
- nest incr
- newPara
- }
- RE {
- nest decr
- }
- RS {
- nest incr
- }
- SE {
- global noFillCount textState inPRE file
-
- font R
- puts -nonewline $file </PRE>
- set inPRE 0
- set noFillCount 0
- nest reset
- newPara
- text "See the "
- font B
- set temp $textState
- set textState REF
- if {[llength $args] > 0} {
- text [lindex $args 0]
- } else {
- text options
- }
- set textState $temp
- font R
- text " manual entry for detailed descriptions of the above options."
- }
- SH {
- SHmacro $args
- }
- SS {
- SHmacro $args subsection
- }
- SO {
- global noFillCount inPRE file
-
- SHmacro "STANDARD OPTIONS"
- setTabs {4c 8c 12c}
- set noFillCount 1000000
- puts -nonewline $file <PRE>
- set inPRE 1
- font B
- }
- so {
- if {$args ne "man.macros"} {
- puts stderr "Unknown macro: .$name [join $args " "]"
- }
- }
- sp { ;# needs work
- if {$args eq ""} {
- set count 1
- } else {
- set count [lindex $args 0]
- }
- while {$count > 0} {
- lineBreak
- incr count -1
- }
- }
- ta {
- setTabs $args
- }
- TH {
- THmacro $args
- }
- TP {
- TPmacro $args
- }
- UL { ;# underline
- global file
- puts -nonewline $file "<B><U>"
- text [lindex $args 0]
- puts -nonewline $file "</U></B>"
- if {[llength $args] == 2} {
- text [lindex $args 1]
- }
- }
- VE {
-# global file
-# puts -nonewline $file "</FONT>"
- }
- VS {
-# global file
-# if {[llength $args] > 0} {
-# puts -nonewline $file "<BR>"
-# }
-# puts -nonewline $file "<FONT COLOR=\"GREEN\">"
- }
- QW {
- puts -nonewline $file "&\#147;"
- text [lindex $args 0]
- puts -nonewline $file "&\#148;"
- if {[llength $args] > 1} {
- text [lindex $args 1]
- }
- }
- PQ {
- puts -nonewline $file "(&\#147;"
- if {[lindex $args 0] eq {\N'34'}} {
- puts -nonewline $file \"
- } else {
- text [lindex $args 0]
- }
- puts -nonewline $file "&\#148;"
- if {[llength $args] > 1} {
- text [lindex $args 1]
- }
- puts -nonewline $file ")"
- if {[llength $args] > 2} {
- text [lindex $args 2]
- }
- }
- QR {
- puts -nonewline $file "&\#147;"
- text [lindex $args 0]
- puts -nonewline $file "&\#148;&\#150;&\#147;"
- text [lindex $args 1]
- puts -nonewline $file "&\#148;"
- if {[llength $args] > 2} {
- text [lindex $args 2]
- }
- }
- MT {
- puts -nonewline $file "&\#147;&\#148;"
- }
- default {
- puts stderr "Unknown macro: .$name [join $args " "]"
- }
- }
-
-# global nestStk; puts "$name [format "%-20s" $args] $nestStk"
-# flush stdout; flush stderr
-}
-
-##############################################################################
-# font --
-#
-# This procedure is invoked to handle font changes in the text being output.
-#
-# Arguments:
-# type - Type of font: R, I, B, or S.
-
-proc font type {
- global textState
- switch $type {
- P -
- R {
- endFont
- if {$textState eq "REF"} {
- set textState INSERT
- }
- }
- B {
- beginFont Code
- if {$textState eq "INSERT"} {
- set textState REF
- }
- }
- I {
- beginFont Emphasis
- }
- S {
- }
- default {
- puts stderr "Unknown font: $type"
- }
- }
-}
-
-##############################################################################
-# formattedText --
-#
-# Insert a text string that may also have \fB-style font changes and a few
-# other backslash sequences in it.
-#
-# Arguments:
-# text - Text to insert.
-
-proc formattedText text {
-# puts "formattedText: $text"
- while {$text ne ""} {
- set index [string first \\ $text]
- if {$index < 0} {
- text $text
- return
- }
- text [string range $text 0 [expr {$index-1}]]
- set c [string index $text [expr {$index+1}]]
- switch -- $c {
- f {
- font [string index $text [expr {$index+2}]]
- set text [string range $text [expr {$index+3}] end]
- }
- e {
- text \\
- set text [string range $text [expr {$index+2}] end]
- }
- - {
- dash
- set text [string range $text [expr {$index+2}] end]
- }
- | {
- set text [string range $text [expr {$index+2}] end]
- }
- default {
- puts stderr "Unknown sequence: \\$c"
- set text [string range $text [expr {$index+2}] end]
- }
- }
- }
-}
-
-##############################################################################
-# dash --
-#
-# This procedure is invoked to handle dash characters ("\-" in troff). It
-# outputs a special dash character.
-#
-# Arguments:
-# None.
-
-proc dash {} {
- global textState charCnt
- if {$textState eq "NAME"} {
- set textState 0
- }
- incr charCnt
- text "-"
-}
-
-##############################################################################
-# tab --
-#
-# This procedure is invoked to handle tabs in the troff input.
-#
-# Arguments:
-# None.
-
-proc tab {} {
- global inPRE charCnt tabString file
-# ? charCnt
- if {$inPRE == 1} {
- set pos [expr {$charCnt % [string length $tabString]}]
- set spaces [string first "1" [string range $tabString $pos end] ]
- text [format "%*s" [incr spaces] " "]
- } else {
-# puts "tab: found tab outside of <PRE> block"
- }
-}
-
-##############################################################################
-# setTabs --
-#
-# This procedure handles the ".ta" macro, which sets tab stops.
-#
-# Arguments:
-# tabList - List of tab stops, each consisting of a number
-# followed by "i" (inch) or "c" (cm).
-
-proc setTabs {tabList} {
- global file breakPending tabString
-
- # puts "setTabs: --$tabList--"
- set last 0
- set tabString {}
- set charsPerInch 14.
- set numTabs [llength $tabList]
- foreach arg $tabList {
- if {[string match +* $arg]} {
- set relative 1
- set arg [string range $arg 1 end]
- } else {
- set relative 0
- }
- # Always operate in relative mode for "measurement" mode
- if {[regexp {^\\w'(.*)'u$} $arg content]} {
- set distance [string length $content]
- } else {
- if {[scan $arg "%f%s" distance units] != 2} {
- puts stderr "bad distance \"$arg\""
- return 0
- }
- switch -- $units {
- c {
- set distance [expr {$distance * $charsPerInch / 2.54}]
- }
- i {
- set distance [expr {$distance * $charsPerInch}]
- }
- default {
- puts stderr "bad units in distance \"$arg\""
- continue
- }
- }
- }
- # ? distance
- if {$relative} {
- append tabString [format "%*s1" [expr {round($distance-1)}] " "]
- set last [expr {$last + $distance}]
- } else {
- append tabString [format "%*s1" [expr {round($distance-$last-1)}] " "]
- set last $distance
- }
- }
- # puts "setTabs: --$tabString--"
-}
-
-##############################################################################
-# lineBreak --
-#
-# Generates a line break in the HTML output.
-#
-# Arguments:
-# None.
-
-proc lineBreak {} {
- global file inPRE
- puts $file "<BR>"
-}
-
-##############################################################################
-# newline --
-#
-# This procedure is invoked to handle newlines in the troff input. It outputs
-# either a space character or a newline character, depending on fill mode.
-#
-# Arguments:
-# None.
-
-proc newline {} {
- global noFillCount file inDT inPRE charCnt inTable
-
- if {$inDT ne ""} {
- puts $file "\n$inDT"
- set inDT {}
- } elseif {$inTable} {
- if {$inTable > 1} {
- puts $file </tr>
- set inTable 1
- }
- } elseif {$noFillCount == 0 || $inPRE == 1} {
- puts $file {}
- } else {
- lineBreak
- incr noFillCount -1
- }
- set charCnt 0
-}
-
-##############################################################################
-# char --
-#
-# This procedure is called to handle a special character.
-#
-# Arguments:
-# name - Special character named in troff \x or \(xx construct.
-
-proc char name {
- global file charCnt
-
- incr charCnt
-# puts "char: $name"
- switch -exact $name {
- \\0 { ;# \0
- puts -nonewline $file " "
- }
- \\\\ { ;# \
- puts -nonewline $file "\\"
- }
- \\(+- { ;# +/-
- puts -nonewline $file "&#177;"
- }
- \\% {} ;# \%
- \\| { ;# \|
- }
- default {
- puts stderr "Unknown character: $name"
- }
- }
-}
-
-##############################################################################
-# macro2 --
-#
-# This procedure handles macros that are invoked with a leading "'" character
-# instead of space. Right now it just generates an error diagnostic.
-#
-# Arguments:
-# name - The name of the macro (without the ".").
-# args - Any additional arguments to the macro.
-
-proc macro2 {name args} {
- puts stderr "Unknown macro: '$name [join $args " "]"
-}
-
-##############################################################################
-# SHmacro --
-#
-# Subsection head; handles the .SH and .SS macros.
-#
-# Arguments:
-# name - Section name.
-# style - Type of section (optional)
-
-proc SHmacro {argList {style section}} {
- global file noFillCount textState charCnt
-
- set args [join $argList " "]
- if {[llength $argList] < 1} {
- puts stderr "Bad .SH macro: .$name $args"
- }
-
- set noFillCount 0
- nest reset
-
- set tag H3
- if {$style eq "subsection"} {
- set tag H4
- }
- puts -nonewline $file "<$tag>"
- text $args
- puts $file "</$tag>"
-
-# ? args textState
-
- # control what the text proc does with text
-
- switch $args {
- NAME {set textState NAME}
- DESCRIPTION {set textState INSERT}
- INTRODUCTION {set textState INSERT}
- "WIDGET-SPECIFIC OPTIONS" {set textState INSERT}
- "SEE ALSO" {set textState SEE}
- KEYWORDS {set textState 0}
- }
- set charCnt 0
-}
-
-##############################################################################
-# IPmacro --
-#
-# This procedure is invoked to handle ".IP" macros, which may take any of the
-# following forms:
-#
-# .IP [1] Translate to a "1Step" paragraph.
-# .IP [x] (x > 1) Translate to a "Step" paragraph.
-# .IP Translate to a "Bullet" paragraph.
-# .IP \(bu Translate to a "Bullet" paragraph.
-# .IP text count Translate to a FirstBody paragraph with
-# special indent and tab stop based on "count",
-# and tab after "text".
-#
-# Arguments:
-# argList - List of arguments to the .IP macro.
-#
-# HTML limitations: 'count' in '.IP text count' is ignored.
-
-proc IPmacro argList {
- global file
-
- setTabs 0.5i
- set length [llength $argList]
- if {$length == 0} {
- nest para UL LI
- return
- }
- # Special case for alternative mechanism for declaring bullets
- if {[lindex $argList 0] eq "\\(bu"} {
- nest para UL LI
- return
- }
- if {[regexp {^\[\d+\]$} [lindex $argList 0]]} {
- nest para OL LI
- return
- }
- nest para DL DT
- formattedText [lindex $argList 0]
- puts $file "\n<DD>"
- return
-}
-
-##############################################################################
-# TPmacro --
-#
-# This procedure is invoked to handle ".TP" macros, which may take any of the
-# following forms:
-#
-# .TP x Translate to an indented paragraph with the specified indent
-# (in 100 twip units).
-# .TP Translate to an indented paragraph with default indent.
-#
-# Arguments:
-# argList - List of arguments to the .IP macro.
-#
-# HTML limitations: 'x' in '.TP x' is ignored.
-
-proc TPmacro {argList} {
- global inDT
- nest para DL DT
- set inDT "\n<DD>" ;# next newline writes inDT
- setTabs 0.5i
-}
-
-##############################################################################
-# THmacro --
-#
-# This procedure handles the .TH macro. It generates the non-scrolling header
-# section for a given man page, and enters information into the table of
-# contents. The .TH macro has the following form:
-#
-# .TH name section date footer header
-#
-# Arguments:
-# argList - List of arguments to the .TH macro.
-
-proc THmacro {argList} {
- global file
-
- if {[llength $argList] != 5} {
- set args [join $argList " "]
- puts stderr "Bad .TH macro: .$name $args"
- }
- set name [lindex $argList 0] ;# Tcl_UpVar
- set page [lindex $argList 1] ;# 3
- set vers [lindex $argList 2] ;# 7.4
- set lib [lindex $argList 3] ;# Tcl
- set pname [lindex $argList 4] ;# {Tcl Library Procedures}
-
- puts -nonewline $file "<HTML><HEAD><TITLE>"
- text "$lib - $name ($page)"
- puts $file "</TITLE></HEAD><BODY>\n"
-
- puts -nonewline $file "<H1><CENTER>"
- text $pname
- puts $file "</CENTER></H1>\n"
-}
-
-##############################################################################
-# newPara --
-#
-# This procedure sets the left and hanging indents for a line. Indents are
-# specified in units of inches or centimeters, and are relative to the current
-# nesting level and left margin.
-#
-# Arguments:
-# None
-
-proc newPara {} {
- global file nestStk
-
- if {[lindex $nestStk end] ne "NEW"} {
- nest decr
- }
- puts -nonewline $file "<P>"
-}
-
-##############################################################################
-# nest --
-#
-# This procedure takes care of inserting the tags associated with the IP, TP,
-# RS, RE, LP and PP macros. Only 'nest para' takes arguments.
-#
-# Arguments:
-# op - operation: para, incr, decr, reset, init
-# listStart - begin list tag: OL, UL, DL.
-# listItem - item tag: LI, LI, DT.
-
-proc nest {op {listStart "NEW"} {listItem ""} } {
- global file nestStk inDT charCnt
-# puts "nest: $op $listStart $listItem"
- switch $op {
- para {
- set top [lindex $nestStk end]
- if {$top eq "NEW"} {
- set nestStk [lreplace $nestStk end end $listStart]
- puts $file "<$listStart>"
- } elseif {$top ne $listStart} {
- puts stderr "nest para: bad stack"
- exit 1
- }
- puts $file "\n<$listItem>"
- set charCnt 0
- }
- incr {
- lappend nestStk NEW
- }
- decr {
- if {[llength $nestStk] == 0} {
- puts stderr "nest error: nest length is zero"
- set nestStk NEW
- }
- set tag [lindex $nestStk end]
- if {$tag ne "NEW"} {
- puts $file "</$tag>"
- }
- set nestStk [lreplace $nestStk end end]
- }
- reset {
- while {[llength $nestStk] > 0} {
- nest decr
- }
- set nestStk NEW
- }
- init {
- set nestStk NEW
- set inDT {}
- }
- }
- set charCnt 0
-}
-
-##############################################################################
-# do --
-#
-# This is the toplevel procedure that translates a man page to HTML. It runs
-# the man2tcl program to turn the man page into a script, then it evals that
-# script.
-#
-# Arguments:
-# fileName - Name of the file to translate.
-
-proc do fileName {
- global file self html_dir package footer
- set self "[file tail $fileName].html"
- set file [open "$html_dir/$package/$self" w]
- puts " Pass 2 -- $fileName"
- flush stdout
- initGlobals
- if {[catch { eval [exec man2tcl [glob $fileName]] } msg]} {
- global errorInfo
- puts stderr $msg
- puts "in"
- puts stderr $errorInfo
- exit 1
- }
- nest reset
- puts $file $footer
- puts $file "</BODY></HTML>"
- close $file
-}
diff --git a/tools/man2tcl.c b/tools/man2tcl.c
deleted file mode 100644
index 66562f9..0000000
--- a/tools/man2tcl.c
+++ /dev/null
@@ -1,424 +0,0 @@
-/*
- * man2tcl.c --
- *
- * This file contains a program that turns a man page of the form used
- * for Tcl and Tk into a Tcl script that invokes a Tcl command for each
- * construct in the man page. The script can then be eval'ed to translate
- * the manual entry into some other format such as MIF or HTML.
- *
- * Usage:
- *
- * man2tcl ?fileName?
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-static char sccsid[] = "@(#) man2tcl.c 1.3 95/08/12 17:34:08";
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <ctype.h>
-#include <errno.h>
-
-/*
- * Imported things that aren't defined in header files:
- */
-
-/*
- * Some <errno.h> define errno to be something complex and thread-aware; in
- * that case we definitely do not want to declare errno ourselves!
- */
-
-#ifndef errno
-extern int errno;
-#endif
-
-/*
- * Current line number, used for error messages.
- */
-
-static int lineNumber;
-
-/*
- * The variable below is set to 1 if an error occurs anywhere while reading in
- * the file.
- */
-
-static int status;
-
-/*
- * The variable below is set to 1 if output should be generated. If it's 0, it
- * means we're doing a prepass to make sure that the file can be properly
- * parsed.
- */
-
-static int writeOutput;
-
-#define PRINT(args) if (writeOutput) { printf args; }
-#define PRINTC(chr) if (writeOutput) { putc((chr), stdout); }
-
-/*
- * Prototypes for functions defined in this file:
- */
-
-static void DoMacro(char *line);
-static void DoText(char *line);
-static void QuoteText(char *string, int count);
-
-/*
- *----------------------------------------------------------------------
- *
- * main --
- *
- * This function is the main program, which does all of the work of the
- * program.
- *
- * Results:
- * None: exits with a 0 return status to indicate success, or 1 to
- * indicate that there were problems in the translation.
- *
- * Side effects:
- * A Tcl script is output to standard output. Error messages may be
- * output on standard error.
- *
- *----------------------------------------------------------------------
- */
-
-int
-main(
- int argc, /* Number of command-line arguments. */
- char **argv) /* Values of command-line arguments. */
-{
- FILE *f;
-#define MAX_LINE_SIZE 4000
- char line[MAX_LINE_SIZE];
- char *p;
-
- /*
- * Find the file to read, and open it if it isn't stdin.
- */
-
- if (argc == 1) {
- f = stdin;
- } else if (argc == 2) {
- f = fopen(argv[1], "r");
- if (f == NULL) {
- fprintf(stderr, "Couldn't read \"%s\": %s\n", argv[1],
- strerror(errno));
- exit(1);
- }
- } else {
- fprintf(stderr, "Usage: %s ?fileName?\n", argv[0]);
- }
-
- /*
- * Make two passes over the file. In the first pass, just check to make
- * sure we can handle everything. If there are problems, generate output
- * and stop. If everything is OK, make a second pass to actually generate
- * output.
- */
-
- for (writeOutput = 0; writeOutput < 2; writeOutput++) {
- lineNumber = 0;
- status = 0;
- while (fgets(line, MAX_LINE_SIZE, f) != NULL) {
- for (p = line; *p != 0; p++) {
- if (*p == '\n') {
- *p = 0;
- break;
- }
- }
- lineNumber++;
-
- if (((line[0] == '.') || (line[0] == '\'')) && (line[1] == '\\') && (line[2] == '\"')) {
- /*
- * This line is a comment. Ignore it.
- */
-
- continue;
- }
-
- if (strlen(line) >= MAX_LINE_SIZE -1) {
- fprintf(stderr, "Too long line. Max is %d chars.\n",
- MAX_LINE_SIZE - 1);
- exit(1);
- }
-
- if ((line[0] == '.') || (line[0] == '\'')) {
- /*
- * This line is a macro invocation.
- */
-
- DoMacro(line);
- } else {
- /*
- * This line is text, possibly with formatting characters
- * embedded in it.
- */
-
- DoText(line);
- }
- }
- if (status != 0) {
- break;
- }
- fseek(f, 0, SEEK_SET);
- }
- exit(status);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DoMacro --
- *
- * This function is called to handle a macro invocation. It parses the
- * arguments to the macro and generates a Tcl command to handle the
- * invocation.
- *
- * Results:
- * None.
- *
- * Side effects:
- * A Tcl command is written to stdout.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DoMacro(
- char *line) /* The line of text that contains the macro
- * invocation. */
-{
- char *p, *end;
- int quote;
-
- /*
- * If there is no macro name, then just skip the whole line.
- */
-
- if ((line[1] == 0) || (isspace(line[1]))) {
- return;
- }
-
- PRINT(("macro"));
- if (*line != '.') {
- PRINT(("2"));
- }
-
- /*
- * Parse the arguments to the macro (including the name), in order.
- */
-
- p = line+1;
- while (1) {
- PRINTC(' ');
- if (*p == '"') {
- /*
- * The argument is delimited by quotes.
- */
-
- for (end = p+1; *end != '"'; end++) {
- if (*end == 0) {
- fprintf(stderr,
- "Unclosed quote in macro call on line %d.\n",
- lineNumber);
- status = 1;
- break;
- }
- }
- QuoteText(p+1, (end-(p+1)));
- } else {
- quote = 0;
- for (end = p+1; (*end != 0) && (quote || !isspace(*end)); end++) {
- if (*end == '\'') {
- quote = !quote;
- }
- }
- QuoteText(p, end-p);
- }
- if (*end == 0) {
- break;
- }
- p = end+1;
- while (isspace(*p)) {
- /*
- * Skip empty space before next argument.
- */
-
- p++;
- }
- if (*p == 0) {
- break;
- }
- }
- PRINTC('\n');
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DoText --
- *
- * This function is called to handle a line of troff text. It parses the
- * text, generating Tcl commands for text and for formatting stuff such
- * as font changes.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Tcl commands are written to stdout.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DoText(
- char *line) /* The line of text. */
-{
- char *p, *end;
-
- /*
- * Divide the line up into pieces consisting of backslash sequences, tabs,
- * and other text.
- */
-
- p = line;
- while (*p != 0) {
- if (*p == '\t') {
- PRINT(("tab\n"));
- p++;
- } else if (*p != '\\') {
- /*
- * Ordinary text.
- */
-
- for (end = p+1; (*end != '\\') && (*end != 0); end++) {
- /* Empty loop body. */
- }
- PRINT(("text "));
- QuoteText(p, end-p);
- PRINTC('\n');
- p = end;
- } else {
- /*
- * A backslash sequence. There are particular ones that we
- * understand; output an error message for anything else and just
- * ignore the backslash.
- */
-
- p++;
- if (*p == 'f') {
- /*
- * Font change.
- */
-
- PRINT(("font %c\n", p[1]));
- p += 2;
- } else if (*p == '-') {
- PRINT(("dash\n"));
- p++;
- } else if (*p == 'e') {
- PRINT(("text \\\\\n"));
- p++;
- } else if (*p == '.') {
- PRINT(("text .\n"));
- p++;
- } else if (*p == '&') {
- p++;
- } else if (*p == '0') {
- PRINT(("text { }\n"));
- p++;
- } else if (*p == '(') {
- if ((p[1] == 0) || (p[2] == 0)) {
- fprintf(stderr, "Bad \\( sequence on line %d.\n",
- lineNumber);
- status = 1;
- } else {
- PRINT(("char {\\(%c%c}\n", p[1], p[2]));
- p += 3;
- }
- } else if (*p == 'N' && *(p+1) == '\'') {
- int ch;
-
- p += 2;
- sscanf(p,"%d",&ch);
- PRINT(("text \\u%04x\n", ch));
- while(*p&&*p!='\'') p++;
- p++;
- } else if (*p != 0) {
- PRINT(("char {\\%c}\n", *p));
- p++;
- }
- }
- }
- PRINT(("newline\n"));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * QuoteText --
- *
- * Copy the "string" argument to stdout, adding quote characters around
- * any special Tcl characters so that they'll just be treated as ordinary
- * text.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Text is written to stdout.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-QuoteText(
- char *string, /* The line of text. */
- int count) /* Number of characters to write from
- * string. */
-{
- if (count == 0) {
- PRINT(("{}"));
- return;
- }
- for ( ; count > 0; string++, count--) {
- switch (*string) {
- case '\\':
- if (*(string+1) == 'N' && *(string+2) == '\'') {
- int ch;
-
- string += 3;
- count -= 3;
- sscanf(string,"%d",&ch);
- PRINT(("\\u%04x", ch));
- while(count>0&&*string!='\'') {string++;count--;}
- continue;
- } else if (*(string+1) == '0') {
- PRINT(("\\ "));
- string++;
- count--;
- continue;
- }
- case '$': case '[': case '{': case ' ': case ';':
- case '"': case '\t':
- PRINTC('\\');
- default:
- PRINTC(*string);
- }
- }
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/tools/mkVfs.tcl b/tools/mkVfs.tcl
new file mode 100644
index 0000000..c4021f6
--- /dev/null
+++ b/tools/mkVfs.tcl
@@ -0,0 +1,99 @@
+proc cat fname {
+ set fname [open $fname r]
+ set data [read $fname]
+ close $fname
+ return $data
+}
+
+proc pkgIndexDir {root fout d1} {
+
+ puts [format {%*sIndexing %s} [expr {4 * [info level]}] {} \
+ [file tail $d1]]
+ set idx [string length $root]
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if {[file isdirectory $f] && [string compare CVS $ftail]} {
+ pkgIndexDir $root $fout $f
+ } elseif {[file tail $f] eq "pkgIndex.tcl"} {
+ puts $fout "set dir \${VFSROOT}[string range $d1 $idx end]"
+ puts $fout [cat $f]
+ }
+ }
+}
+
+###
+# Script to build the VFS file system
+###
+proc copyDir {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]} {
+ copyDir $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
+ }
+}
+
+if {[llength $argv] < 3} {
+ puts "Usage: VFS_ROOT TCLSRC_ROOT PLATFORM"
+ exit 1
+}
+set TCL_SCRIPT_DIR [lindex $argv 0]
+set TCLSRC_ROOT [lindex $argv 1]
+set PLATFORM [lindex $argv 2]
+set TKDLL [lindex $argv 3]
+set TKVER [lindex $argv 4]
+
+puts "Building [file tail $TCL_SCRIPT_DIR] for $PLATFORM"
+copyDir ${TCLSRC_ROOT}/library ${TCL_SCRIPT_DIR}
+
+if {$PLATFORM == "windows"} {
+ set ddedll [glob -nocomplain ${TCLSRC_ROOT}/win/tcldde*.dll]
+ puts "DDE DLL $ddedll"
+ if {$ddedll != {}} {
+ file copy $ddedll ${TCL_SCRIPT_DIR}/dde
+ }
+ set regdll [glob -nocomplain ${TCLSRC_ROOT}/win/tclreg*.dll]
+ puts "REG DLL $ddedll"
+ if {$regdll != {}} {
+ file copy $regdll ${TCL_SCRIPT_DIR}/reg
+ }
+} else {
+ # Remove the dde and reg package paths
+ file delete -force ${TCL_SCRIPT_DIR}/dde
+ file delete -force ${TCL_SCRIPT_DIR}/reg
+}
+
+# For the following packages, cat their pkgIndex files to tclIndex
+file attributes ${TCL_SCRIPT_DIR}/tclIndex -readonly 0
+set fout [open ${TCL_SCRIPT_DIR}/tclIndex a]
+puts $fout {#
+# MANIFEST OF INCLUDED PACKAGES
+#
+set VFSROOT $dir
+}
+if {$TKDLL ne {} && [file exists $TKDLL]} {
+ file copy $TKDLL ${TCL_SCRIPT_DIR}
+ puts $fout [list package ifneeded Tk $TKVER "load \$dir $TKDLL"]
+}
+pkgIndexDir ${TCL_SCRIPT_DIR} $fout ${TCL_SCRIPT_DIR}
+close $fout
diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl
index 90a3b92..b02e396 100644
--- a/tools/mkdepend.tcl
+++ b/tools/mkdepend.tcl
@@ -2,7 +2,7 @@
#
# mkdepend : generate dependency information from C/C++ files
#
-# Copyright (c) 1998, Nat Pryce
+# Copyright © 1998, Nat Pryce
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl
index a94d90f..71dc909 100644
--- a/tools/regexpTestLib.tcl
+++ b/tools/regexpTestLib.tcl
@@ -4,7 +4,7 @@
# spencer2regexp.tcl, which are programs written to convert Henry
# Spencer's test suite to tcl test files.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright © 1996 Sun Microsystems, Inc.
proc readInputFile {} {
global inFileName
@@ -42,7 +42,7 @@ proc readInputFile {} {
#
# strings with embedded @'s are truncated
-# unpreceeded @'s are replaced by {}
+# unpreceded @'s are replaced by {}
#
proc removeAts {ls} {
set len [llength $ls]
@@ -105,7 +105,7 @@ proc writeOutputFile {numLines fcn} {
puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to"
puts $fileId "# -1 will run tests that are known to fail."
puts $fileId "#"
- puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
+ puts $fileId "# Copyright © 1998 Sun Microsystems, Inc."
puts $fileId "#"
puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
@@ -192,7 +192,7 @@ proc convertTestLine {currentLine len lineNum srcLineNum} {
# if and \r substitutions are made, do not wrap re, flags,
# str, and result in braces
- set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine]
+ set noBraces [regsub -all {R} $currentLine {\\\x0D} currentLine]
regsub -all {T} $currentLine {\\t} currentLine
regsub -all {V} $currentLine {\\v} currentLine
if {[regexp {=} $flags] == 1} {
diff --git a/tools/str2c b/tools/str2c
deleted file mode 100644
index e2c5208..0000000
--- a/tools/str2c
+++ /dev/null
@@ -1,59 +0,0 @@
-#! /bin/sh
-#
-# Transform text (.ps, .tcl,...) into a C string
-#
-# 1997/10 -- dl
-#
-# restart with tclsh \
-exec tclsh "$0" ${1+"$@"}
-
-# Max string length
-# (some C compiler have a 2048 chars limits (so 2047 real chars with
-# the tariling 0) so we use 2000 to make the count nice)
-set MAX 2000
-
-if {$argc} {
- puts stderr "Usage: [file tail [info script]] < text > text.c"
- exit 1
-}
-
-set r [read stdin]
-
-proc translate {what} {
- regsub -all {\\} $what {\\\\} what
- regsub -all {"} $what {\\"} what
- regsub -all "\n" $what "\\\\n\\\\\n" what;
- return $what;
-}
-
-set lg [string length $r]
-if {$lg<$MAX} {
- puts "/*
- * Single part writable string generated by str2c
- */
-static char data\[\]=\"[translate $r]\";"
-} else {
- puts "/*
- * Multi parts read only string generated by str2c
- */
-static const char * const data\[\]= {"
- set n 1
- for {set i 0} {$i<$lg} {incr i $MAX} {
- set part [string range $r $i [expr {$i+$MAX-1}]]
- set len [string length $part];
- puts "\t/* Start of part $n ($len characters) */"
- puts "\t\"[translate $part]\","
- puts "\t/* End of part $n */\n"
- incr n
- }
- puts "\tNULL\t/* End of data marker */\n};"
- puts "\n/* use for instance with:
- const char * const *chunk;
- for (chunk=data; *chunk; chunk++) {
- Tcl_AppendResult(interp, *chunk, (char *) NULL);
- }
-*/"
-}
-
-
-
diff --git a/tools/tcl.hpj.in b/tools/tcl.hpj.in
deleted file mode 100644
index a94cea6..0000000
--- a/tools/tcl.hpj.in
+++ /dev/null
@@ -1,19 +0,0 @@
-; This file is maintained by HCW. Do not modify this file directly.
-
-[OPTIONS]
-HCW=0
-LCID=0x409 0x0 0x0 ;English (United States)
-REPORT=Yes
-TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
-COPYRIGHT=Copyright 2000 Ajuba Solutions
-HLP=tcl86.hlp
-
-[FILES]
-tcl.rtf
-
-[WINDOWS]
-main="Tcl/Tk Reference Manual",,0
-
-[CONFIG]
-BrowseButtons()
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
new file mode 100644
index 0000000..941f15c
--- /dev/null
+++ b/tools/tclOOScript.tcl
@@ -0,0 +1,456 @@
+# 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 © 2012-2018 Donal K. Fellows
+# Copyright © 2013 Andreas Kupries
+# Copyright © 2017 Gerald Lester
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+::namespace eval ::oo {
+ ::namespace path {}
+
+ #
+ # Commands that are made available to objects by default.
+ #
+ namespace eval Helpers {
+ ::namespace path {}
+
+ # ------------------------------------------------------------------
+ #
+ # callback, mymethod --
+ #
+ # Create a script prefix that calls a method on the current
+ # object. Same operation, two names.
+ #
+ # ------------------------------------------------------------------
+
+ proc callback {method args} {
+ list [uplevel 1 {::namespace which my}] $method {*}$args
+ }
+
+ # Make the [callback] command appear as [mymethod] too.
+ namespace export callback
+ namespace eval tmp {namespace import ::oo::Helpers::callback}
+ namespace export -clear
+ rename tmp::callback mymethod
+ namespace delete tmp
+
+ # ------------------------------------------------------------------
+ #
+ # classvariable --
+ #
+ # Link to a variable in the class of the current object.
+ #
+ # ------------------------------------------------------------------
+
+ proc classvariable {name args} {
+ # Get a reference to the class's namespace
+ set ns [info object namespace [uplevel 1 {self class}]]
+ # Double up the list of variable names
+ foreach v [list $name {*}$args] {
+ if {[string match *(*) $v]} {
+ set reason "can't create a scalar variable that looks like an array element"
+ return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
+ [format {bad variable name "%s": %s} $v $reason]
+ }
+ if {[string match *::* $v]} {
+ set reason "can't create a local variable with a namespace separator in it"
+ return -code error -errorcode {TCL UPVAR INVERTED} \
+ [format {bad variable name "%s": %s} $v $reason]
+ }
+ lappend vs $v $v
+ }
+ # Lastly, link the caller's local variables to the class's variables
+ tailcall namespace upvar $ns {*}$vs
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # link --
+ #
+ # Make a command that invokes a method on the current object.
+ # The name of the command and the name of the method match by
+ # default.
+ #
+ # ------------------------------------------------------------------
+
+ proc link {args} {
+ set ns [uplevel 1 {::namespace current}]
+ foreach link $args {
+ if {[llength $link] == 2} {
+ lassign $link src dst
+ } elseif {[llength $link] == 1} {
+ lassign $link src
+ set dst $src
+ } else {
+ return -code error -errorcode {TCLOO CMDLINK FORMAT} \
+ "bad link description; must only have one or two elements"
+ }
+ if {![string match ::* $src]} {
+ set src [string cat $ns :: $src]
+ }
+ interp alias {} $src {} ${ns}::my $dst
+ trace add command ${ns}::my delete [list \
+ ::oo::UnlinkLinkedCommand $src]
+ }
+ return
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # UnlinkLinkedCommand --
+ #
+ # Callback used to remove linked command when the underlying mechanism
+ # that supports it is deleted.
+ #
+ # ----------------------------------------------------------------------
+
+ proc UnlinkLinkedCommand {cmd args} {
+ if {[namespace which $cmd] ne {}} {
+ rename $cmd {}
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # DelegateName --
+ #
+ # Utility that gets the name of the class delegate for a class. It's
+ # trivial, but makes working with them much easier as delegate names are
+ # intentionally hard to create by accident.
+ #
+ # ----------------------------------------------------------------------
+
+ proc DelegateName {class} {
+ string cat [info object namespace $class] {:: oo ::delegate}
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # MixinClassDelegates --
+ #
+ # Support code called *after* [oo::define] inside the constructor of a
+ # class that patches in the appropriate class delegates.
+ #
+ # ----------------------------------------------------------------------
+
+ proc MixinClassDelegates {class} {
+ if {![info object isa class $class]} {
+ return
+ }
+ set delegate [DelegateName $class]
+ if {![info object isa class $delegate]} {
+ return
+ }
+ foreach c [info class superclass $class] {
+ set d [DelegateName $c]
+ if {![info object isa class $d]} {
+ continue
+ }
+ define $delegate ::oo::define::superclass -append $d
+ }
+ objdefine $class ::oo::objdefine::mixin -append $delegate
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # UpdateClassDelegatesAfterClone --
+ #
+ # Support code that is like [MixinClassDelegates] except for when a
+ # class is cloned.
+ #
+ # ----------------------------------------------------------------------
+
+ proc UpdateClassDelegatesAfterClone {originObject targetObject} {
+ # Rebuild the class inheritance delegation class
+ set originDelegate [DelegateName $originObject]
+ set targetDelegate [DelegateName $targetObject]
+ if {
+ [info object isa class $originDelegate]
+ && ![info object isa class $targetDelegate]
+ } then {
+ copy $originDelegate $targetDelegate
+ objdefine $targetObject ::oo::objdefine::mixin -set \
+ {*}[lmap c [info object mixin $targetObject] {
+ if {$c eq $originDelegate} {set targetDelegate} {set c}
+ }]
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::classmethod --
+ #
+ # Defines a class method. See define(n) for details.
+ #
+ # Note that the ::oo::define namespace is semi-public and a bit weird
+ # anyway, so we don't regard the namespace path as being under control:
+ # fully qualified names are used for everything.
+ #
+ # ----------------------------------------------------------------------
+
+ proc define::classmethod {name args} {
+ # Create the method on the class if the caller gave arguments and body
+ ::set argc [::llength [::info level 0]]
+ ::if {$argc == 3} {
+ ::return -code error -errorcode {TCL WRONGARGS} [::format \
+ {wrong # args: should be "%s name ?args body?"} \
+ [::lindex [::info level 0] 0]]
+ }
+ ::set cls [::uplevel 1 self]
+ ::if {$argc == 4} {
+ ::oo::define [::oo::DelegateName $cls] method $name {*}$args
+ }
+ # Make the connection by forwarding
+ ::tailcall forward $name myclass $name
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::initialise, oo::define::initialize --
+ #
+ # Do specific initialisation for a class. See define(n) for details.
+ #
+ # Note that the ::oo::define namespace is semi-public and a bit weird
+ # anyway, so we don't regard the namespace path as being under control:
+ # fully qualified names are used for everything.
+ #
+ # ----------------------------------------------------------------------
+
+ proc define::initialise {body} {
+ ::set clsns [::info object namespace [::uplevel 1 self]]
+ ::tailcall apply [::list {} $body $clsns]
+ }
+
+ # Make the [initialise] definition appear as [initialize] too
+ namespace eval define {
+ ::namespace export initialise
+ ::namespace eval tmp {::namespace import ::oo::define::initialise}
+ ::namespace export -clear
+ ::rename tmp::initialise initialize
+ ::namespace delete tmp
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # Slot --
+ #
+ # The class of slot operations, which are basically lists at the low
+ # level of TclOO; this provides a more consistent interface to them.
+ #
+ # ----------------------------------------------------------------------
+
+ define Slot {
+ # ------------------------------------------------------------------
+ #
+ # Slot Get --
+ #
+ # Basic slot getter. Retrieves the contents of the slot.
+ # Particular slots must provide concrete non-erroring
+ # implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Get {} {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot Set --
+ #
+ # Basic slot setter. Sets the contents of the slot. Particular
+ # slots must provide concrete non-erroring implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Set list {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot Resolve --
+ #
+ # Helper that lets a slot convert a list of arguments of a
+ # particular type to their canonical forms. Defaults to doing
+ # nothing (suitable for simple strings).
+ #
+ # ------------------------------------------------------------------
+
+ method Resolve list {
+ return $list
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot -set, -append, -clear, --default-operation --
+ #
+ # Standard public slot operations. If a slot can't figure out
+ # what method to call directly, it uses --default-operation.
+ #
+ # ------------------------------------------------------------------
+
+ method -set args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ tailcall my Set $args
+ }
+ method -append args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ set current [uplevel 1 [list $my Get]]
+ tailcall my Set [list {*}$current {*}$args]
+ }
+ method -clear {} {tailcall my Set {}}
+ method -prepend args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ set current [uplevel 1 [list $my Get]]
+ tailcall my Set [list {*}$args {*}$current]
+ }
+ method -remove args {
+ set my [namespace which my]
+ set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
+ set current [uplevel 1 [list $my Get]]
+ tailcall my Set [lmap val $current {
+ if {$val in $args} continue else {set val}
+ }]
+ }
+
+ # Default handling
+ forward --default-operation my -append
+ method unknown {args} {
+ set def --default-operation
+ if {[llength $args] == 0} {
+ tailcall my $def
+ } elseif {![string match -* [lindex $args 0]]} {
+ tailcall my $def {*}$args
+ }
+ next {*}$args
+ }
+
+ # Set up what is exported and what isn't
+ export -set -append -clear -prepend -remove
+ unexport unknown destroy
+ }
+
+ # Set the default operation differently for these slots
+ objdefine define::superclass forward --default-operation my -set
+ objdefine define::mixin forward --default-operation my -set
+ objdefine objdefine::mixin forward --default-operation my -set
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::object <cloned> --
+ #
+ # Handler for cloning objects that clones basic bits (only!) of the
+ # object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+ # more complex (and class-specific) handling.
+ #
+ # ----------------------------------------------------------------------
+
+ define object method <cloned> {originObject} {
+ # Copy over the procedures from the original namespace
+ foreach p [info procs [info object namespace $originObject]::*] {
+ set args [info args $p]
+ set idx -1
+ foreach a $args {
+ if {[info default $p $a d]} {
+ lset args [incr idx] [list $a $d]
+ } else {
+ lset args [incr idx] [list $a]
+ }
+ }
+ set b [info body $p]
+ set p [namespace tail $p]
+ proc $p $args $b
+ }
+ # Copy over the variables from the original namespace
+ 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
+ }
+ }
+ }
+ # General commands, sub-namespaces and advancd variable config (traces,
+ # etc) are *not* copied over. Classes that want that should do it
+ # themselves.
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::class <cloned> --
+ #
+ # Handler for cloning classes, which fixes up the delegates.
+ #
+ # ----------------------------------------------------------------------
+
+ define class method <cloned> {originObject} {
+ next $originObject
+ # Rebuild the class inheritance delegation class
+ ::oo::UpdateClassDelegatesAfterClone $originObject [self]
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::singleton --
+ #
+ # A metaclass that is used to make classes that only permit one instance
+ # of them to exist. See singleton(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create singleton {
+ superclass class
+ variable object
+ unexport create createWithNamespace
+ method new args {
+ if {![info exists object] || ![info object isa object $object]} {
+ set object [next {*}$args]
+ ::oo::objdefine $object {
+ method destroy {} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not destroy a singleton object"
+ }
+ method <cloned> {originObject} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not clone a singleton object"
+ }
+ }
+ }
+ return $object
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::abstract --
+ #
+ # A metaclass that is used to make classes that can't be directly
+ # instantiated. See abstract(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create abstract {
+ superclass class
+ unexport create createWithNamespace new
+ }
+}
+
+# Local Variables:
+# mode: tcl
+# c-basic-offset: 4
+# fill-column: 78
+# End:
diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl
index 71242d6..b3dd667 100755
--- a/tools/tclZIC.tcl
+++ b/tools/tclZIC.tcl
@@ -25,7 +25,7 @@
#
#----------------------------------------------------------------------
#
-# Copyright (c) 2004 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.
#----------------------------------------------------------------------
@@ -1263,7 +1263,7 @@ proc writeZones {outDir} {
# Write the data to the information file
set f [open $fileName w]
- fconfigure $f -translation lf
+ fconfigure $f -translation lf -encoding utf-8
puts $f "\# created by $::argv0 - do not edit"
puts $f ""
puts $f [list set TZData(:$zoneName) $data]
@@ -1316,7 +1316,7 @@ proc writeLinks {outDir} {
# Write the file
set f [open $fileName w]
- fconfigure $f -translation lf
+ fconfigure $f -translation lf -encoding utf-8
puts $f "\# created by $::argv0 - do not edit"
puts $f $ifCmd
puts $f $setCmd
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index 6e4f1fb..78aa8ec 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -3,8 +3,8 @@
## functions are specifically intended to work with the format as used
## by Tcl and Tk; they do not cope with arbitrary nroff markup.
##
-## Copyright (c) 1995-1997 Roger E. Critchlow Jr
-## Copyright (c) 2004-2011 Donal K. Fellows
+## Copyright © 1995-1997 Roger E. Critchlow Jr
+## Copyright © 2004-2011 Donal K. Fellows
set ::manual(report-level) 1
@@ -43,14 +43,14 @@ proc indexfile {} {
if {[info exists ::TARGET] && $::TARGET eq "devsite"} {
return "index.tml"
} else {
- return "contents.htm"
+ return "index.html"
}
}
proc copyright {copyright {level {}}} {
# We don't actually generate a separate copyright page anymore
- #set page "${level}copyright.htm"
- #return "<A HREF=\"$page\">Copyright</A> &copy; [htmlize-text [lrange $copyright 2 end]]"
+ #set page "${level}copyright.html"
+ #return "<a href=\"$page\">Copyright</a> &copy; [htmlize-text [lrange $copyright 2 end]]"
# obfuscate any email addresses that may appear in name
set who [string map {@ (at)} [lrange $copyright 2 end]]
return "Copyright &copy; [htmlize-text $who]"
@@ -61,7 +61,7 @@ proc copyout {copyrights {level {}}} {
set out "<div class=\"copy\">"
foreach c $copyrights {
if {$count > 0} {
- append out <BR>
+ append out <br>
}
append out "[copyright $c $level]\n"
incr count
@@ -74,21 +74,17 @@ proc CSS {{level ""}} {
return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n"
}
-proc DOCTYPE {} {
- return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">"
-}
-
proc htmlhead {title header args} {
set level ""
if {[lindex $args end] eq "../[indexfile]"} {
# XXX hack - assume same level for CSS file
set level "../"
}
- set out "[DOCTYPE]\n<HTML>\n<HEAD><TITLE>$title</TITLE>\n[CSS $level]</HEAD>\n"
+ set out "<!DOCTYPE html>\n<html lang=\"en\">\n<head><meta charset=\"utf-8\"><title>$title</title>\n[CSS $level]</head>\n"
foreach {uptitle url} $args {
set header "<a href=\"$url\">$uptitle</a> <small>&gt;</small> $header"
}
- append out "<BODY><H2>$header</H2>"
+ append out "<body><h2>$header</h2>"
global manual
if {[info exists manual(subheader)]} {
set subs {}
@@ -96,10 +92,10 @@ proc htmlhead {title header args} {
if {$name eq $title} {
lappend subs $name
} else {
- lappend subs "<A HREF=\"${level}$subdir/[indexfile]\">$name</A>"
+ lappend subs "<a href=\"${level}$subdir/[indexfile]\">$name</a>"
}
}
- append out "\n<H3>[join $subs { | }]</H3>"
+ append out "\n<h3>[join $subs { | }]</h3>"
}
return $out
}
@@ -116,6 +112,10 @@ proc parse-directive {line codename restname} {
return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest]
}
+proc nospace-text {text} {
+ return [regsub -all " " $text _]
+}
+
proc htmlize-text {text {charmap {}}} {
# contains some extras for use in nroff->html processing
# build on the list passed in, if any
@@ -220,19 +220,19 @@ proc process-text {text} {
while {[string first "\\" $text] >= 0} {
# C R
if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
- {\1<TT>\2</TT>\3} text]} continue
+ {\1<tt>\2</tt>\3} text]} continue
# B R
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
- {\1<B>\2</B>\3} text]} continue
+ {\1<b>\2</b>\3} text]} continue
# B I
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
- {\1<B>\2</B>\\fI\3} text]} continue
+ {\1<b>\2</b>\\fI\3} text]} continue
# I R
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
- {\1<I>\2</I>\3} text]} continue
+ {\1<i>\2</i>\3} text]} continue
# I B
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
- {\1<I>\2</I>\\fB\3} text]} continue
+ {\1<i>\2</i>\\fB\3} text]} continue
# B B, I I, R R
if {
[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
@@ -372,8 +372,8 @@ proc long-toc {text} {
set manual($manual(name)-id-$text) $here
set there L[incr manual(long-toc-n)]
lappend manual(section-toc) \
- "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
- return "<A NAME=\"$here\">$text</A>"
+ "<dd><a href=\"$manual(name).html#$here\" name=\"[nospace-text $there]\" id=\"[nospace-text $there]\">$text</a>"
+ return "<a name=\"[nospace-text $here]\" id=\"[nospace-text $here]\">$text</a>"
}
proc option-toc {name class switch} {
@@ -398,24 +398,24 @@ proc option-toc {name class switch} {
set here M$first
set there L[incr manual(long-toc-n)]
set manual(standard-option-$manual(name)-$first) \
- "<A HREF=\"$manual(name).htm#$here\">$switch, $name, $class</A>"
+ "<a href=\"$manual(name).html#$here\">$switch, $name, $class</a>"
lappend manual(section-toc) \
- "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>"
- return "<A NAME=\"$here\">$switch</A>"
+ "<dd><a href=\"$manual(name).html#$here\" name=\"[nospace-text $there]\" id=\"[nospace-text $there]\">$switch, $name, $class</a>"
+ return "<a name=\"[nospace-text $here]\" id=\"[nospace-text $here]\">$switch</a>"
}
proc std-option-toc {name page} {
global manual
if {[info exists manual(standard-option-$page-$name)]} {
- lappend manual(section-toc) <DD>$manual(standard-option-$page-$name)
+ lappend manual(section-toc) <dd>$manual(standard-option-$page-$name)
return $manual(standard-option-$page-$name)
}
manerror "missing reference to \"$name\" in $page.n"
set here M[incr manual(section-toc-n)]
set there L[incr manual(long-toc-n)]
set other M$name
- lappend manual(section-toc) "<DD><A HREF=\"$page.htm#$other\">$name</A>"
- return "<A HREF=\"$page.htm#$other\">$name</A>"
+ lappend manual(section-toc) "<dd><a href=\"$page.html#$other\">$name</a>"
+ return "<a href=\"$page.html#$other\">$name</a>"
}
##
@@ -424,8 +424,8 @@ proc std-option-toc {name page} {
##
proc output-widget-options {rest} {
global manual
- man-puts <DL>
- lappend manual(section-toc) <DL>
+ man-puts <dl>
+ lappend manual(section-toc) <dl>
backup-text 1
set para {}
while {[next-op-is .OP rest]} {
@@ -456,11 +456,11 @@ proc output-widget-options {rest} {
if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
error "not Class: $class"
}
- man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
- man-puts "<DT>Database Name: $oname$name$cname"
- man-puts "<DT>Database Class: $oclass$class$cclass"
- man-puts <DD>[next-text]
- set para <P>
+ man-puts "$para<dt>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
+ man-puts "<dt>Database Name: $oname$name$cname"
+ man-puts "<dt>Database Class: $oclass$class$cclass"
+ man-puts <dd>[next-text]
+ set para <p>
if {[next-op-is .RS rest]} {
while {[more-text]} {
@@ -486,8 +486,8 @@ proc output-widget-options {rest} {
}
}
}
- man-puts </DL>
- lappend manual(section-toc) </DL>
+ man-puts </dl>
+ lappend manual(section-toc) </dl>
}
##
@@ -498,18 +498,18 @@ proc output-RS-list {} {
if {[next-op-is .IP rest]} {
output-IP-list .RS .IP $rest
if {[match-text .RE .sp .RS @rest .IP @rest2]} {
- man-puts <P>$rest
+ man-puts <p>$rest
output-IP-list .RS .IP $rest2
}
if {[match-text .RE .sp .RS @rest .RE]} {
- man-puts <P>$rest
+ man-puts <p>$rest
return
}
if {[next-op-is .RE rest]} {
return
}
}
- man-puts <DL><DD>
+ man-puts <dl><dd>
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
@@ -531,7 +531,7 @@ proc output-RS-list {} {
man-puts $line
}
}
- man-puts </DL>
+ man-puts </dl>
}
##
@@ -542,13 +542,13 @@ proc output-IP-list {context code rest} {
global manual
if {![string length $rest]} {
# blank label, plain indent, no contents entry
- man-puts <DL><DD>
+ man-puts <dl><dd>
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
if {$code eq ".IP" && $rest eq {}} {
- man-puts "<P>"
+ man-puts "<p>"
continue
}
if {$code in {.br .DS .RS}} {
@@ -561,21 +561,21 @@ proc output-IP-list {context code rest} {
man-puts $line
}
}
- man-puts </DL>
+ man-puts </dl>
} else {
# labelled list, make contents
if {$context ne ".SH" && $context ne ".SS"} {
- man-puts <P>
+ man-puts <p>
}
- set dl "<DL class=\"[string tolower $manual(section)]\">"
- set enddl "</DL>"
+ set dl "<dl class=\"[string tolower $manual(section)]\">"
+ set enddl "</dl>"
if {$code eq ".IP"} {
if {[regexp {^\[[\da-f]+\]|\(?[\da-f]+\)$} $rest]} {
- set dl "<OL class=\"[string tolower $manual(section)]\">"
- set enddl "</OL>"
+ set dl "<ol class=\"[string tolower $manual(section)]\">"
+ set enddl "</ol>"
} elseif {"&bull;" eq $rest} {
- set dl "<UL class=\"[string tolower $manual(section)]\">"
- set enddl "</UL>"
+ set dl "<ul class=\"[string tolower $manual(section)]\">"
+ set enddl "</ul>"
}
}
man-puts $dl
@@ -594,15 +594,15 @@ proc output-IP-list {context code rest} {
continue
}
if {$manual(section) eq "ARGUMENTS"} {
- man-puts "$para<DT>$rest<DD>"
+ man-puts "$para<dt>$rest<dd>"
} elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} {
- man-puts "$para<LI value=\"$value\">"
+ man-puts "$para<li value=\"$value\">"
} elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} {
- man-puts "$para<LI value=\"$value\">"
+ man-puts "$para<li value=\"$value\">"
} elseif {"&bull;" eq $rest} {
- man-puts "$para<LI>"
+ man-puts "$para<li>"
} else {
- man-puts "$para<DT>[long-toc $rest]<DD>"
+ man-puts "$para<dt>[long-toc $rest]<dd>"
}
}
.sp - .br - .DS - .CS {
@@ -628,18 +628,18 @@ proc output-IP-list {context code rest} {
.PP {
if {[match-text @rest1 .br @rest2 .RS]} {
# yet another nroff kludge as above
- man-puts "$para<DT>[long-toc $rest1]"
- man-puts "<DT>[long-toc $rest2]<DD>"
+ man-puts "$para<dt>[long-toc $rest1]"
+ man-puts "<dt>[long-toc $rest2]<dd>"
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
if {!$accept_RE} {
- man-puts "$enddl<P>$rest$dl"
+ man-puts "$enddl<p>$rest$dl"
backup-text 1
set para {}
break
}
- man-puts "<P>$rest"
+ man-puts "<p>$rest"
incr accept_RE -1
} elseif {$accept_RE} {
output-directive $line
@@ -663,7 +663,7 @@ proc output-IP-list {context code rest} {
} else {
man-puts $line
}
- set para <P>
+ set para <p>
}
man-puts "$para$enddl"
lappend manual(section-toc) $enddl
@@ -686,7 +686,7 @@ proc output-name {line} {
# output line to manual page untouched
man-puts "$head &mdash; $tail"
# output line to long table of contents
- lappend manual(section-toc) "<DL><DD>$head &mdash; $tail</DD></DL>"
+ lappend manual(section-toc) "<dl><dd>$head &mdash; $tail</dd></dl>"
# separate out the names for future reference
foreach name [split $head ,] {
set name [string trim $name]
@@ -696,7 +696,7 @@ proc output-name {line} {
lappend manual(wing-toc) $name
lappend manual(name-$name) $manual(wing-file)/$manual(name)
}
- set manual(tooltip-$manual(wing-file)/$manual(name).htm) $line
+ set manual(tooltip-$manual(wing-file)/$manual(name).html) $line
}
##
@@ -721,7 +721,7 @@ proc cross-reference {ref} {
[regexp {^[A-Z0-9 ?!]+$} $ref]
&& [info exists manual($manname-id-$ref)]
} {
- return "<A HREF=\"#$manual($manname-id-$ref)\">$ref</A>"
+ return "<a href=\"#$manual($manname-id-$ref)\">$ref</a>"
} else {
set lref [string tolower $ref]
##
@@ -743,7 +743,7 @@ proc cross-reference {ref} {
(![info exists exclude_refs_map($mantail)] ||
$manual(name-$name) ni $exclude_refs_map($mantail))
} {
- return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>"
+ return "<a href=\"../$manual(name-$name).html\">$ref</a>"
}
}
if {$lref in {end}} {
@@ -768,17 +768,17 @@ proc cross-reference {ref} {
if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd"
|| $manual(wing-file) eq "TclLib"} {
set tcl_ref [lindex $manref $tcl_i]
- return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
+ return "<a href=\"../$tcl_ref.html\">$ref</a>"
}
set tk_i [lsearch -glob $manref *TkCmd*]
if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd"
|| $manual(wing-file) eq "TkLib"} {
set tk_ref [lindex $manref $tk_i]
- return "<A HREF=\"../$tk_ref.htm\">$ref</A>"
+ return "<a href=\"../$tk_ref.html\">$ref</a>"
}
if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} {
set tcl_ref [lindex $manref $tcl_i]
- return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
+ return "<a href=\"../$tcl_ref.html\">$ref</a>"
}
puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
return $ref
@@ -805,7 +805,7 @@ proc cross-reference {ref} {
##
## return the cross reference
##
- return "<A HREF=\"../$manref.htm\">$ref</A>"
+ return "<a href=\"../$manref.html\">$ref</a>"
}
##
@@ -828,7 +828,7 @@ proc insert-cross-references {text} {
##
## we identify cross references by:
## ``quotation''
- ## <B>emboldening</B>
+ ## <b>emboldening</b>
## Tcl_ prefix
## Tk_ prefix
## [a-zA-Z0-9]+ manual entry
@@ -839,9 +839,9 @@ proc insert-cross-references {text} {
##
unset -nocomplain offsets
foreach {name pattern} {
- anchor {<A } end-anchor {</A>}
+ anchor {<a } end-anchor {</a>}
quote {``} end-quote {''}
- bold {<B>} end-bold {</B>}
+ bold {<b>} end-bold {</b>}
c.tcl {Tcl_}
c.tk {Tk_}
c.ttk {Ttk_}
@@ -926,8 +926,8 @@ proc insert-cross-references {text} {
[expr {$offset(end-bold)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
- regsub {http://[\w/.-]+} $body {<A HREF="&">&</A>} body
- append result <B> [cross-reference $body] </B>
+ regsub {http://[\w/.-]+} $body {<a href="&">&</a>} body
+ append result <b> [cross-reference $body] </b>
continue
}
anchor {
@@ -970,7 +970,7 @@ proc insert-cross-references {text} {
}
regexp -indices -start $off {http://[\w/.-]+} $text range
set url [string range $text {*}$range]
- append result "<A HREF=\"[string trimright $url .]\">$url</A>"
+ append result "<a href=\"[string trimright $url .]\">$url</a>"
set text [string range $text[set text ""] \
[expr {[lindex $range 1]+1}] end]
continue
@@ -991,7 +991,7 @@ proc output-directive {line} {
split-directive $line code rest
switch -exact -- $code {
.BS - .BE {
- # man-puts <HR>
+ # man-puts <hr>
}
.SH - .SS {
# drain any open lists
@@ -1001,9 +1001,9 @@ proc output-directive {line} {
set manual($manual(name)-$manual(section)) {}
lappend manual(has-$manual(section)) $manual(name)
if {$code ne ".SS"} {
- man-puts "<H3>[long-toc $manual(section)]</H3>"
+ man-puts "<h3>[long-toc $manual(section)]</h3>"
} else {
- man-puts "<H4>[long-toc $manual(section)]</H4>"
+ man-puts "<h4>[long-toc $manual(section)]</h4>"
}
# some sections can simply free wheel their way through the text
# some sections can be processed in their own loops
@@ -1023,7 +1023,7 @@ proc output-directive {line} {
}
}
H:SYNOPSIS {
- lappend manual(section-toc) <DL>
+ lappend manual(section-toc) <dl>
while {1} {
if {
[next-op-is .nf rest]
@@ -1042,7 +1042,7 @@ proc output-directive {line} {
break
}
if {[next-op-is .sp rest]} {
- #man-puts <P>
+ #man-puts <p>
continue
}
set more [next-text]
@@ -1055,15 +1055,15 @@ proc output-directive {line} {
regexp {^(\s*)(.*)} $more -> spaces more
set spaces [string map {" " "&nbsp;"} $spaces]
if {[string length $spaces]} {
- set spaces <TT>$spaces</TT>
+ set spaces <tt>$spaces</tt>
}
- man-puts $spaces$more<BR>
+ man-puts $spaces$more<br>
if {$manual(wing-file) in {TclLib TkLib}} {
- lappend manual(section-toc) <DD>$more
+ lappend manual(section-toc) <dd>$more
}
}
}
- lappend manual(section-toc) </DL>
+ lappend manual(section-toc) </dl>
return
}
{H:SEE ALSO} {
@@ -1081,11 +1081,11 @@ proc output-directive {line} {
set nmore {}
foreach cr [split $more ,] {
set cr [string trim $cr]
- if {![regexp {^<B>.*</B>$} $cr]} {
- set cr <B>$cr</B>
+ if {![regexp {^<b>.*</b>$} $cr]} {
+ set cr <b>$cr</b>
}
- if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} {
- set cr <B>$name</B>
+ if {[regexp {^<b>(.*)\([13n]\)</b>$} $cr all name]} {
+ set cr <b>$name</b>
}
lappend nmore $cr
}
@@ -1109,9 +1109,9 @@ proc output-directive {line} {
foreach key [split $more ,] {
set key [string trim $key]
lappend manual(keyword-$key) [list $manual(name) \
- $manual(wing-file)/$manual(name).htm]
+ $manual(wing-file)/$manual(name).html]
set initial [string toupper [string index $key 0]]
- lappend keys "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>"
+ lappend keys "<a href=\"../Keywords/$initial.html\#$key\">$key</a>"
}
man-puts [join $keys {, }]
}
@@ -1143,14 +1143,14 @@ proc output-directive {line} {
}
}
output-directive {.SH STANDARD OPTIONS}
- man-puts <DL>
- lappend manual(section-toc) <DL>
+ man-puts <dl>
+ lappend manual(section-toc) <dl>
foreach optionpair [lsort -dictionary -index 0 $optslist] {
lassign $optionpair option targetPage
- man-puts "<DT><B>[std-option-toc $option $targetPage]</B>"
+ man-puts "<dt><b>[std-option-toc $option $targetPage]</b>"
}
- man-puts </DL>
- lappend manual(section-toc) </DL>
+ man-puts </dl>
+ lappend manual(section-toc) </dl>
}
.OP {
output-widget-options $rest
@@ -1161,14 +1161,14 @@ proc output-directive {line} {
return
}
.PP - .sp {
- man-puts <P>
+ man-puts <p>
}
.RS {
output-RS-list
return
}
.br {
- man-puts <BR>
+ man-puts <br>
return
}
.DS {
@@ -1179,9 +1179,9 @@ proc output-directive {line} {
set td "<td><p class=\"tablecell\">"
set bodyText [string map [list \n <tr>$td \t $td] \n$stuff]
man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>"
- #man-puts <PRE>$stuff</PRE>
+ #man-puts <pre>$stuff</pre>
} elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
- man-puts "<PRE>[lindex $ul1 1][lindex $ul2 1]\n$stuff</PRE>"
+ man-puts "<pre>[lindex $ul1 1][lindex $ul2 1]\n$stuff</pre>"
} else {
manerror "unexpected .DS format:\n[expand-next-text 2]"
}
@@ -1192,7 +1192,7 @@ proc output-directive {line} {
# ???
}
if {[match-text @stuff .CE]} {
- man-puts <PRE>$stuff</PRE>
+ man-puts <pre>$stuff</pre>
} else {
manerror "unexpected .CS format:\n[expand-next-text 2]"
}
@@ -1201,54 +1201,54 @@ proc output-directive {line} {
.nf {
if {[match-text @more .fi]} {
foreach more [split $more \n] {
- man-puts $more<BR>
+ man-puts $more<br>
}
} elseif {[match-text .RS @more .RE .fi]} {
- man-puts <DL><DD>
+ man-puts <dl><dd>
foreach more [split $more \n] {
- man-puts $more<BR>
+ man-puts $more<br>
}
- man-puts </DL>
+ man-puts </dl>
} elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
- man-puts <DL><DD>
+ man-puts <dl><dd>
foreach more [split $more \n] {
- man-puts $more<BR>
+ man-puts $more<br>
}
- man-puts <DL><DD>
+ man-puts <dl><dd>
foreach more2 [split $more2 \n] {
- man-puts $more2<BR>
+ man-puts $more2<br>
}
- man-puts </DL></DL>
+ man-puts </dl></dl>
} elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
- man-puts <DL><DD>
+ man-puts <dl><dd>
foreach more [split $more \n] {
- man-puts $more<BR>
+ man-puts $more<br>
}
- man-puts <DL><DD>
+ man-puts <dl><dd>
foreach more2 [split $more2 \n] {
- man-puts $more2<BR>
+ man-puts $more2<br>
}
- man-puts </DL><DD>
+ man-puts </dl><dd>
foreach more3 [split $more3 \n] {
- man-puts $more3<BR>
+ man-puts $more3<br>
}
- man-puts </DL>
+ man-puts </dl>
} elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
- man-puts <P><DL><DD>
+ man-puts <p><dl><dd>
foreach more [split $more \n] {
- man-puts $more<BR>
+ man-puts $more<br>
}
- man-puts <DL><DD>
+ man-puts <dl><dd>
foreach more2 [split $more2 \n] {
- man-puts $more2<BR>
+ man-puts $more2<br>
}
- man-puts </DL></DL><P>
+ man-puts </dl></dl><p>
} elseif {[match-text .RS .sp @more .sp .RE .fi]} {
- man-puts <P><DL><DD>
+ man-puts <p><dl><dd>
foreach more [split $more \n] {
- man-puts $more<BR>
+ man-puts $more<br>
}
- man-puts </DL><P>
+ man-puts </dl><p>
} else {
manerror "ignoring $line"
}
@@ -1329,9 +1329,9 @@ proc make-manpage-section {outputDir sectionDescriptor} {
puts stderr "scanning section $manual(wing-name)"
# put the entry for this section into the short table of contents
if {[regexp {^(.+), version (.+)$} $manual(wing-name) -> name version]} {
- puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\" TITLE=\"version $version\">$name</A></DT><DD>$manual(wing-description)</DD>"
+ puts $manual(short-toc-fp) "<dt><a href=\"$manual(wing-file)/[indexfile]\" title=\"version $version\">$name</a></dt><dd>$manual(wing-description)</dd>"
} else {
- puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>"
+ puts $manual(short-toc-fp) "<dt><a href=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</a></dt><dd>$manual(wing-description)</dd>"
}
# initialize the wing table of contents
puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \
@@ -1618,7 +1618,7 @@ proc make-manpage-section {outputDir sectionDescriptor} {
# make the long table of contents for this page
#
set manual(toc-$manual(wing-file)-$manual(name)) \
- [concat <DL> $manual(section-toc) </DL>]
+ [concat <dl> $manual(section-toc) </dl>]
}
if {!$verbose} {
puts stderr ""
@@ -1648,15 +1648,15 @@ proc make-manpage-section {outputDir sectionDescriptor} {
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
- if {[info exists manual(tooltip-$manual(wing-file)/$tail.htm)]} {
- set tooltip $manual(tooltip-$manual(wing-file)/$tail.htm)
+ if {[info exists manual(tooltip-$manual(wing-file)/$tail.html)]} {
+ set tooltip $manual(tooltip-$manual(wing-file)/$tail.html)
set tooltip [string map {[ {\[} ] {\]} $ {\$} \\ \\\\} $tooltip]
regsub {^[^-]+-\s*(.)} $tooltip {[string totitle \1]} tooltip
append rows([expr {$n%$nrows}]) \
- "<td> <a href=\"$tail.htm\" title=\"[subst $tooltip]\">$name</a> </td>"
+ "<td> <a href=\"$tail.html\" title=\"[subst $tooltip]\">$name</a> </td>"
} else {
append rows([expr {$n%$nrows}]) \
- "<td> <a href=\"$tail.htm\">$name</a> </td>"
+ "<td> <a href=\"$tail.html\">$name</a> </td>"
}
incr n
}
@@ -1670,7 +1670,7 @@ proc make-manpage-section {outputDir sectionDescriptor} {
# insert wing copyrights
#
puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"]
- puts $manual(wing-toc-fp) "</BODY></HTML>"
+ puts $manual(wing-toc-fp) "</body></html>"
close $manual(wing-toc-fp)
set manual(merge-copyrights) \
[merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index caececa..5f211f3 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -19,10 +19,10 @@ if {[catch {package require Tcl 8.6-} msg]} {
# into hypertext, not as a general solution to the problem. If you
# try to use this, you'll be very much on your own.
#
-# Copyright (c) 1995-1997 Roger E. Critchlow Jr
-# Copyright (c) 2004-2010 Donal K. Fellows
+# Copyright © 1995-1997 Roger E. Critchlow Jr
+# Copyright © 2004-2010 Donal K. Fellows
-set ::Version "50/8.6"
+set ::Version "50/8.7"
set ::CSSFILE "docs.css"
##
@@ -31,6 +31,52 @@ set ::CSSFILE "docs.css"
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
+proc getversion {tclh {name {}}} {
+ if {[file exists $tclh]} {
+ set chan [open $tclh]
+ set data [read $chan]
+ close $chan
+ if {$name eq ""} {
+ set name [string toupper [file root [file tail $tclh]]]
+ }
+ # backslash isn't required in front of quote, but it keeps syntax
+ # highlighting straight in some editors
+ if {[regexp -lineanchor \
+ [string map [list @name@ $name] \
+ {^#\s*define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \
+ $data -> major minor]} {
+ return [list $major $minor]
+ }
+ }
+}
+proc findversion {top name useversion} {
+ # Default search version is a glob pattern, switch it for string match:
+ if {$useversion eq {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}} {
+ set useversion {[8-9].[0-9]}
+ }
+ # Search:
+ set upper [string toupper $name]
+ foreach top1 [list $top $top/..] sub {{} generic} {
+ foreach dirname [
+ glob -nocomplain -tails -type d -directory $top1 *] {
+
+ set tclh [join [list $top1 $dirname {*}$sub ${name}.h] /]
+ set v [getversion $tclh $upper]
+ if {[llength $v]} {
+ lassign $v major minor
+ # to do
+ # use glob matching instead of string matching or add
+ # brace handling to [string matcch]
+ if {$useversion eq "" || [string match $useversion $major.$minor]} {
+ set top [file dirname [file dirname $tclh]]
+ set prefix [file dirname $top]
+ return [list $prefix [file tail $top] $major $minor]
+ }
+ }
+ }
+ }
+}
+
proc parse_command_line {} {
global argv Version
@@ -44,7 +90,9 @@ proc parse_command_line {} {
set tcldir {}
set webdir ../html
set build_tcl 0
+ set opt_build_tcl 0
set build_tk 0
+ set opt_build_tk 0
set verbose 0
# Default search version is a glob pattern
set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}
@@ -93,10 +141,12 @@ proc parse_command_line {} {
--tcl {
set build_tcl 1
+ set opt_build_tcl 1
}
--tk {
set build_tk 1
+ set opt_build_tk 1
}
--verbose=* {
@@ -115,26 +165,44 @@ proc parse_command_line {} {
set build_tk 1
}
+ set major ""
+ set minor ""
+
if {$build_tcl} {
- # Find Tcl
+ # Find Tcl (firstly using glob pattern / backwards compatible way)
set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tcl$useversion]] end]
- if {$tcldir eq ""} {
+ if {$tcldir ne ""} {
+ # obtain version from generic header if we can:
+ lassign [getversion [file join $tcltkdir $tcldir generic tcl.h]] major minor
+ } else {
+ lassign [findversion $tcltkdir tcl $useversion] tcltkdir tcldir major minor
+ }
+ if {$tcldir eq "" && $opt_build_tcl} {
puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
exit 1
}
- puts "using Tcl source directory $tcldir"
+ puts "using Tcl source directory [file join $tcltkdir $tcldir]"
}
+
if {$build_tk} {
- # Find Tk
+ # Find Tk (firstly using glob pattern / backwards compatible way)
set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tk$useversion]] end]
- if {$tkdir eq ""} {
+ if {$tkdir ne ""} {
+ if {$major eq ""} {
+ # obtain version from generic header if we can:
+ lassign [getversion [file join $tcltkdir $tkdir generic tk.h]] major minor
+ }
+ } else {
+ lassign [findversion $tcltkdir tk $useversion] tcltkdir tkdir major minor
+ }
+ if {$tkdir eq "" && $opt_build_tk} {
puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
exit 1
}
- puts "using Tk source directory $tkdir"
+ puts "using Tk source directory [file join $tcltkdir $tkdir]"
}
puts "verbose messages are [expr {$verbose ? {on} : {off}}]"
@@ -143,7 +211,11 @@ proc parse_command_line {} {
global overall_title
set overall_title ""
if {$build_tcl} {
- append overall_title "[capitalize $tcldir]"
+ if {$major ne ""} {
+ append overall_title "Tcl $major.$minor"
+ } else {
+ append overall_title "Tcl [capitalize $tcldir]"
+ }
}
if {$build_tcl && $build_tk} {
append overall_title "/"
@@ -264,7 +336,7 @@ proc make-man-pages {html args} {
set manual(short-toc-fp) [open $html/[indexfile] w]
fconfigure $manual(short-toc-fp) -translation lf -encoding utf-8
puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title]
- puts $manual(short-toc-fp) "<DL class=\"keylist\">"
+ puts $manual(short-toc-fp) "<dl class=\"keylist\">"
set manual(merge-copyrights) {}
foreach arg $args {
@@ -309,13 +381,13 @@ proc make-man-pages {html args} {
foreach a $letters {
set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
if {[llength $keys]} {
- lappend keyheader "<A HREF=\"$a.htm\">$a</A>"
+ lappend keyheader "<a href=\"$a.html\">$a</a>"
} else {
# No keywords for this letter
lappend keyheader $a
}
}
- set keyheader <H3>[join $keyheader " |\n"]</H3>
+ set keyheader <h3>[join $keyheader " |\n"]</h3>
puts $keyfp $keyheader
foreach a $letters {
set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
@@ -323,17 +395,17 @@ proc make-man-pages {html args} {
continue
}
# Per-keyword page
- set afp [open $html/Keywords/$a.htm w]
+ set afp [open $html/Keywords/$a.html w]
fconfigure $afp -translation lf -encoding utf-8
puts $afp [htmlhead "$tcltkdesc Keywords - $a" \
"$tcltkdesc Keywords - $a" \
$overall_title "../[indexfile]"]
puts $afp $keyheader
- puts $afp "<DL class=\"keylist\">"
+ puts $afp "<dl class=\"keylist\">"
foreach k [lsort -dictionary $keys] {
set k [string range $k 8 end]
- puts $afp "<DT><A NAME=\"$k\">$k</A></DT>"
- puts $afp "<DD>"
+ puts $afp "<dt><a name=\"[nospace-text $k]\" id=\"[nospace-text $k]\">$k</a></dt>"
+ puts $afp "<dd>"
set refs {}
foreach man $manual(keyword-$k) {
set name [lindex $man 0]
@@ -343,32 +415,32 @@ proc make-man-pages {html args} {
if {[string match {*[<>""]*} $tooltip]} {
manerror "bad tooltip for $file: \"$tooltip\""
}
- lappend refs "<A HREF=\"../$file\" TITLE=\"$tooltip\">$name</A>"
+ lappend refs "<a href=\"../$file\" title=\"$tooltip\">$name</a>"
} else {
- lappend refs "<A HREF=\"../$file\">$name</A>"
+ lappend refs "<a href=\"../$file\">$name</a>"
}
}
- puts $afp "[join $refs {, }]</DD>"
+ puts $afp "[join $refs {, }]</dd>"
}
- puts $afp "</DL>"
+ puts $afp "</dl>"
# insert merged copyrights
puts $afp [copyout $manual(merge-copyrights)]
- puts $afp "</BODY></HTML>"
+ puts $afp "</body></html>"
close $afp
}
# insert merged copyrights
puts $keyfp [copyout $manual(merge-copyrights)]
- puts $keyfp "</BODY></HTML>"
+ puts $keyfp "</body></html>"
close $keyfp
##
## finish off short table of contents
##
- puts $manual(short-toc-fp) "<DT><A HREF=\"Keywords/[indexfile]\">Keywords</A><DD>The keywords from the $tcltkdesc man pages."
- puts $manual(short-toc-fp) "</DL>"
+ puts $manual(short-toc-fp) "<dt><a href=\"Keywords/[indexfile]\">Keywords</a><dd>The keywords from the $tcltkdesc man pages."
+ puts $manual(short-toc-fp) "</dl>"
# insert merged copyrights
puts $manual(short-toc-fp) [copyout $manual(merge-copyrights)]
- puts $manual(short-toc-fp) "</BODY></HTML>"
+ puts $manual(short-toc-fp) "</body></html>"
close $manual(short-toc-fp)
##
@@ -400,7 +472,7 @@ proc make-man-pages {html args} {
} else {
puts -nonewline stderr .
}
- set outfd [open $html/$manual(wing-file)/$manual(name).htm w]
+ set outfd [open $html/$manual(wing-file)/$manual(name).html w]
fconfigure $outfd -translation lf -encoding utf-8
puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \
$manual(name) $wing_name "[indexfile]" \
@@ -419,7 +491,7 @@ proc make-man-pages {html args} {
foreach item $text {
puts $outfd [insert-cross-references $item]
}
- puts $outfd "</BODY></HTML>"
+ puts $outfd "</body></html>"
} on error msg {
if {$verbose} {
puts stderr $msg
@@ -610,7 +682,7 @@ array set exclude_refs_map {
ttk_scale.n {variable}
ttk_scrollbar.n {set}
ttk_spinbox.n {format}
- ttk_treeview.n {text open}
+ ttk_treeview.n {text open focus selection}
ttk_widget.n {image text variable}
TclZlib.3 {binary flush filename text}
}
@@ -741,9 +813,9 @@ try {
[list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \
"The interpreters which implement $cmdesc."] \
[plus-base $build_tcl $tcldir doc/*.n {Tcl Commands} TclCmd \
- "The commands which the <B>tclsh</B> interpreter implements."] \
+ "The commands which the <b>tclsh</b> interpreter implements."] \
[plus-base $build_tk $tkdir doc/*.n {Tk Commands} TkCmd \
- "The additional commands which the <B>wish</B> interpreter implements."] \
+ "The additional commands which the <b>wish</b> interpreter implements."] \
{*}[plus-pkgs n {*}$packageBuildList] \
[plus-base $build_tcl $tcldir doc/*.3 {Tcl C API} TclLib \
"The C functions which a Tcl extended C program may use."] \
diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c
index a75e962..4c96f28 100644
--- a/tools/tsdPerf.c
+++ b/tools/tsdPerf.c
@@ -1,25 +1,25 @@
#include <tcl.h>
-extern DLLEXPORT Tcl_PackageInitProc Tsdperf_Init;
+extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
- int value;
+ Tcl_WideInt value;
} TsdPerf;
static int
tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) {
TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf));
- int i;
+ Tcl_WideInt i;
if (2 != objc) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
- if (TCL_OK != Tcl_GetIntFromObj(interp, objv[1], &i)) {
+ if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &i)) {
return TCL_ERROR;
}
@@ -33,7 +33,7 @@ tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const
TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf));
- Tcl_SetObjResult(interp, Tcl_NewIntObj(perf->value));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(perf->value));
return TCL_OK;
}
diff --git a/tools/ucm2tests.tcl b/tools/ucm2tests.tcl
new file mode 100644
index 0000000..dc878ef
--- /dev/null
+++ b/tools/ucm2tests.tcl
@@ -0,0 +1,352 @@
+# ucm2tests.tcl
+#
+# Parses given ucm files (from ICU) to generate test data
+# for encodings.
+#
+# tclsh ucm2tests.tcl PATH_TO_ICU_UCM_DIRECTORY ?OUTPUTPATH?
+#
+
+namespace eval ucm {
+ # No means to change these currently but ...
+ variable outputPath
+ variable outputChan
+ variable errorChan stderr
+ variable verbose 0
+
+ # Map Tcl encoding name to ICU UCM file name
+ variable encNameMap
+ array set encNameMap {
+ cp1250 glibc-CP1250-2.1.2
+ cp1251 glibc-CP1251-2.1.2
+ cp1252 glibc-CP1252-2.1.2
+ cp1253 glibc-CP1253-2.1.2
+ cp1254 glibc-CP1254-2.1.2
+ cp1255 glibc-CP1255-2.1.2
+ cp1256 glibc-CP1256-2.1.2
+ cp1257 glibc-CP1257-2.1.2
+ cp1258 glibc-CP1258-2.1.2
+ gb1988 glibc-GB_1988_80-2.3.3
+ iso8859-1 glibc-ISO_8859_1-2.1.2
+ iso8859-2 glibc-ISO_8859_2-2.1.2
+ iso8859-3 glibc-ISO_8859_3-2.1.2
+ iso8859-4 glibc-ISO_8859_4-2.1.2
+ iso8859-5 glibc-ISO_8859_5-2.1.2
+ iso8859-6 glibc-ISO_8859_6-2.1.2
+ iso8859-7 glibc-ISO_8859_7-2.3.3
+ iso8859-8 glibc-ISO_8859_8-2.3.3
+ iso8859-9 glibc-ISO_8859_9-2.1.2
+ iso8859-10 glibc-ISO_8859_10-2.1.2
+ iso8859-11 glibc-ISO_8859_11-2.1.2
+ iso8859-13 glibc-ISO_8859_13-2.3.3
+ iso8859-14 glibc-ISO_8859_14-2.1.2
+ iso8859-15 glibc-ISO_8859_15-2.1.2
+ iso8859-16 glibc-ISO_8859_16-2.3.3
+ }
+
+ # Array keyed by Tcl encoding name. Each element contains mapping of
+ # Unicode code point -> byte sequence for that encoding as a flat list
+ # (or dictionary). Both are stored as hex strings
+ variable charMap
+
+ # Array keyed by Tcl encoding name. List of invalid code sequences
+ # each being a hex string.
+ variable invalidCodeSequences
+
+ # Array keyed by Tcl encoding name. List of unicode code points that are
+ # not mapped, each being a hex string.
+ variable unmappedCodePoints
+
+ # The fallback character per encoding
+ variable encSubchar
+}
+
+proc ucm::abort {msg} {
+ variable errorChan
+ puts $errorChan $msg
+ exit 1
+}
+proc ucm::warn {msg} {
+ variable errorChan
+ puts $errorChan $msg
+}
+proc ucm::log {msg} {
+ variable verbose
+ if {$verbose} {
+ variable errorChan
+ puts $errorChan $msg
+ }
+}
+proc ucm::print {s} {
+ variable outputChan
+ puts $outputChan $s
+}
+
+proc ucm::parse_SBCS {encName fd} {
+ variable charMap
+ variable invalidCodeSequences
+ variable unmappedCodePoints
+
+ set result {}
+ while {[gets $fd line] >= 0} {
+ if {[string match #* $line]} {
+ continue
+ }
+ if {[string equal "END CHARMAP" [string trim $line]]} {
+ break
+ }
+ if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} {
+ error "Unexpected line parsing SBCS: $line"
+ }
+ set bytes [string map {\\x {}} $bytes]; # \xNN -> NN
+ if {$precision eq "" || $precision eq "0"} {
+ lappend result $unichar $bytes
+ } else {
+ # It is a fallback mapping - ignore
+ }
+ }
+ set charMap($encName) $result
+
+ # Find out invalid code sequences and unicode code points that are not mapped
+ set valid {}
+ set mapped {}
+ foreach {unich bytes} $result {
+ lappend mapped $unich
+ lappend valid $bytes
+ }
+ set invalidCodeSequences($encName) {}
+ for {set i 0} {$i <= 255} {incr i} {
+ set hex [format %.2X $i]
+ if {[lsearch -exact $valid $hex] < 0} {
+ lappend invalidCodeSequences($encName) $hex
+ }
+ }
+
+ set unmappedCodePoints($encName) {}
+ for {set i 0} {$i <= 65535} {incr i} {
+ set hex [format %.4X $i]
+ if {[lsearch -exact $mapped $hex] < 0} {
+ lappend unmappedCodePoints($encName) $hex
+ # Only look for (at most) one below 256 and one above 1024
+ if {$i < 255} {
+ # Found one so jump past 8 bits
+ set i 255
+ } else {
+ break
+ }
+ }
+ if {$i == 255} {
+ set i 1023
+ }
+ }
+ lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF
+}
+
+proc ucm::generate_boilerplate {} {
+ # Common procedures
+ print {
+# 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
+ }
+}
+ }
+} ; # generate_boilerplate
+
+proc ucm::generate_tests {} {
+ variable encNameMap
+ variable charMap
+ variable invalidCodeSequences
+ variable unmappedCodePoints
+ variable outputPath
+ variable outputChan
+ variable encSubchar
+
+ if {[info exists outputPath]} {
+ set outputChan [open $outputPath w]
+ fconfigure $outputChan -translation lf
+ } else {
+ set outputChan stdout
+ }
+
+ array set tclNames {}
+ foreach encName [encoding names] {
+ set tclNames($encName) ""
+ }
+
+ generate_boilerplate
+ foreach encName [lsort -dictionary [array names encNameMap]] {
+ if {![info exists charMap($encName)]} {
+ warn "No character map read for $encName"
+ continue
+ }
+ unset tclNames($encName)
+
+ # Print the valid tests
+ print "\n#\n# $encName (generated from $encNameMap($encName))"
+ print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{"
+ print " ucmConvertfromMismatches $encName {$charMap($encName)}"
+ print "\} -result {}"
+ print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{"
+ print " ucmConverttoMismatches $encName {$charMap($encName)}"
+ print "\} -result {}"
+ if {0} {
+ # This will generate individual tests for every char
+ # and test in lead, tail, middle, solo configurations
+ # but takes considerable time
+ print "lappend encValidStrings \{*\}\{"
+ foreach {unich hex} $charMap($encName) {
+ print " $encName \\u$unich $hex {} {}"
+ }
+ print "\}; # $encName"
+ }
+
+ # Generate the invalidity checks
+ print "\n# $encName - invalid byte sequences"
+ print "lappend encInvalidBytes \{*\}\{"
+ foreach hex $invalidCodeSequences($encName) {
+ # Map XXXX... to \xXX\xXX...
+ set uhex [regsub -all .. $hex {\\x\0}]
+ set uhex \\U[string range 00000000$hex end-7 end]
+ print " $encName $hex tcl8 $uhex -1 {} {}"
+ print " $encName $hex replace \\uFFFD -1 {} {}"
+ print " $encName $hex strict {} 0 {} {}"
+ }
+ print "\}; # $encName"
+
+ print "\n# $encName - invalid byte sequences"
+ print "lappend encUnencodableStrings \{*\}\{"
+ if {[info exists encSubchar($encName)]} {
+ set subchar $encSubchar($encName)
+ } else {
+ set subchar "3F"; # Tcl uses ? by default
+ }
+ foreach hex $unmappedCodePoints($encName) {
+ set uhex \\U[string range 00000000$hex end-7 end]
+ print " $encName $uhex tcl8 $subchar -1 {} {}"
+ print " $encName $uhex replace $subchar -1 {} {}"
+ print " $encName $uhex strict {} 0 {} {}"
+ }
+ print "\}; # $encName"
+ }
+
+ if {[array size tclNames]} {
+ warn "Missing encoding: [lsort [array names tclNames]]"
+ }
+ if {[info exists outputPath]} {
+ close $outputChan
+ unset outputChan
+ }
+}
+
+proc ucm::parse_file {encName ucmPath} {
+ variable charMap
+ variable encSubchar
+
+ set fd [open $ucmPath]
+ try {
+ # Parse the metadata
+ unset -nocomplain state
+ while {[gets $fd line] >= 0} {
+ if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} {
+ set state($key) $val
+ } elseif {[regexp {^\s*CHARMAP\s*$} $line]} {
+ set state(charmap) ""
+ break
+ } else {
+ # Skip all else
+ }
+ }
+ if {![info exists state(charmap)]} {
+ abort "Error: $ucmPath has No CHARMAP line."
+ }
+ foreach key {code_set_name uconv_class} {
+ if {[info exists state($key)]} {
+ set state($key) [string trim $state($key) {"}]
+ }
+ }
+ if {[info exists charMap($encName)]} {
+ abort "Duplicate file for $encName ($path)"
+ }
+ if {![info exists state(uconv_class)]} {
+ abort "Error: $ucmPath has no uconv_class definition."
+ }
+ if {[info exists state(subchar)]} {
+ # \xNN\xNN.. -> NNNN..
+ set encSubchar($encName) [string map {\\x {}} $state(subchar)]
+ }
+ switch -exact -- $state(uconv_class) {
+ SBCS {
+ if {[catch {
+ parse_SBCS $encName $fd
+ } result]} {
+ abort "Could not process $ucmPath. $result"
+ }
+ }
+ default {
+ log "Skipping $ucmPath -- not SBCS encoding."
+ return
+ }
+ }
+ } finally {
+ close $fd
+ }
+}
+
+proc ucm::run {} {
+ variable encNameMap
+ variable outputPath
+ switch [llength $::argv] {
+ 2 {set outputPath [lindex $::argv 1]}
+ 1 {}
+ default {
+ abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?"
+ }
+ }
+ foreach {encName fname} [array get encNameMap] {
+ ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm]
+ }
+ generate_tests
+}
+
+ucm::run
diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl
index aec5864..3acf19c 100644
--- a/tools/uniParse.tcl
+++ b/tools/uniParse.tcl
@@ -6,7 +6,7 @@
# UnicodeData file from:
# ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt
#
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
@@ -185,7 +185,7 @@ proc uni::main {} {
* automatically generated by the tools/uniParse.tcl script. Do not
* modify this file by hand.
*
- * Copyright (c) 1998 Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
* All rights reserved.
*/
diff --git a/tools/valgrind_check_success b/tools/valgrind_check_success
new file mode 100644
index 0000000..24830d5
--- /dev/null
+++ b/tools/valgrind_check_success
@@ -0,0 +1,30 @@
+#! /usr/bin/env tclsh
+
+
+proc main {sourcetype source} {
+ switch $sourcetype {
+ file {
+ set chan [open $source]
+ try {
+ set data [read $chan]
+ } finally {
+ close $chan
+ }
+ }
+ string {
+ set data $source
+ }
+ default {
+ error [list {wrong # args}]
+ }
+ }
+ set found [regexp -inline -all {blocks are\
+ (?:(?:(?:definitely|indirectly|possibly) lost)|still reachable)} $data]
+ if {[llength $found]} {
+ puts 0
+ } else {
+ puts 1
+ }
+ flush stdout
+}
+main {*}$argv
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 21d4085..e092a2d 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -170,13 +170,13 @@ TCLTEST_EXE = tcltest${EXE_SUFFIX}
NATIVE_TCLSH = @TCLSH_PROG@
# The symbols below provide support for dynamic loading and shared libraries.
-# See configure.in for a description of what the symbols mean. The values of
+# See configure.ac for a description of what the symbols mean. The values of
# the symbols are normally set by the configure script. You shouldn't normally
# need to modify any of these definitions by hand.
STLIB_LD = @STLIB_LD@
SHLIB_LD = @SHLIB_LD@
-SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tcl
+SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@
TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@
@@ -240,6 +240,7 @@ TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library
ZLIB_DIR = ${COMPAT_DIR}/zlib
ZLIB_INCLUDE = @ZLIB_INCLUDE@
TOMMATH_DIR = $(TOP_DIR)/libtommath
+TOMMATH_INCLUDE = @TOMMATH_INCLUDE@
CC = @CC@
OBJEXT = @OBJEXT@
@@ -270,8 +271,6 @@ VALGRINDARGS = --tool=memcheck --num-callers=24 \
--keep-debuginfo=yes \
--suppressions=$(TOOL_DIR)/valgrind_suppress
-shquotequote = $(subst ",\",$(subst ',\',$(1)))
-shquotesingle = $(subst ','\'',$(1))
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
@@ -279,12 +278,12 @@ shquotesingle = $(subst ','\'',$(1))
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
- ${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \
- @EXTRA_CC_SWITCHES@
+ ${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ \
+ ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
-CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
+CC_SWITCHES = $(STUB_CC_SWITCHES) -DBUILD_tcl
-APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
+APP_CC_SWITCHES = $(STUB_CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
@@ -300,8 +299,8 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o
GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
- tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \
- tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
+ tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \
+ tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \
tclEncoding.o tclEnsemble.o \
@@ -312,12 +311,12 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
tclPkg.o tclPkgConfig.o tclPosixStr.o \
- tclPreserve.o tclProc.o tclRegexp.o \
+ tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o \
tclStrToD.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
- tclTomMathInterface.o
+ tclTomMathInterface.o tclZipfs.o
OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
tclOOMethod.o tclOOStubInit.o
@@ -329,17 +328,20 @@ TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \
bn_mp_cnt_lsb.o bn_mp_copy.o \
bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \
bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o bn_mp_expt_u32.o \
+ bn_mp_get_mag_u64.o \
bn_mp_grow.o bn_mp_init.o \
bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \
bn_mp_init_size.o bn_s_mp_karatsuba_mul.o \
+ bn_mp_init_i64.o bn_mp_init_u64.o \
bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \
bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \
bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o \
bn_mp_pack_count.o bn_mp_radix_size.o bn_mp_radix_smap.o \
- bn_mp_read_radix.o bn_mp_rshd.o bn_mp_shrink.o \
- bn_mp_set.o \
+ bn_mp_set_i64.o bn_mp_read_radix.o bn_mp_rshd.o \
+ bn_mp_set_u64.o bn_mp_shrink.o \
bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \
- bn_mp_signed_rsh.o bn_mp_to_ubin.o bn_mp_unpack.o \
+ bn_mp_signed_rsh.o \
+ bn_mp_to_ubin.o bn_mp_unpack.o \
bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o bn_mp_to_radix.o \
bn_mp_ubin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o
@@ -354,7 +356,7 @@ UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \
tclUnixTime.o tclUnixInit.o tclUnixThrd.o \
tclUnixCompat.o
-NOTIFY_OBJS = tclUnixNotfy.o
+NOTIFY_OBJS = tclEpollNotfy.o tclKqueueNotfy.o tclSelectNotfy.o
MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o
@@ -368,7 +370,7 @@ ZLIB_OBJS = Zadler32.o Zcompress.o Zcrc32.o Zdeflate.o Zinfback.o \
TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
${OO_OBJS} @DL_OBJS@ @PLAT_OBJS@
-OBJS = ${TCL_OBJS} @DTRACE_OBJ@ @ZLIB_OBJS@ ${TOMMATH_OBJS}
+OBJS = ${TCL_OBJS} @DTRACE_OBJ@ @ZLIB_OBJS@ @TOMMATH_OBJS@
TCL_DECLS = \
$(GENERIC_DIR)/tcl.decls \
@@ -391,7 +393,8 @@ GENERIC_HDRS = \
$(GENERIC_DIR)/tclPatch.h \
$(GENERIC_DIR)/tclPlatDecls.h \
$(GENERIC_DIR)/tclPort.h \
- $(GENERIC_DIR)/tclRegexp.h
+ $(GENERIC_DIR)/tclRegexp.h \
+ $(GENERIC_DIR)/tclArithSeries.h
GENERIC_SRCS = \
$(GENERIC_DIR)/regcomp.c \
@@ -399,6 +402,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/regfree.c \
$(GENERIC_DIR)/regerror.c \
$(GENERIC_DIR)/tclAlloc.c \
+ $(GENERIC_DIR)/tclArithSeries.c \
$(GENERIC_DIR)/tclAssembly.c \
$(GENERIC_DIR)/tclAsync.c \
$(GENERIC_DIR)/tclBasic.c \
@@ -453,6 +457,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclPosixStr.c \
$(GENERIC_DIR)/tclPreserve.c \
$(GENERIC_DIR)/tclProc.c \
+ $(GENERIC_DIR)/tclProcess.c \
$(GENERIC_DIR)/tclRegexp.c \
$(GENERIC_DIR)/tclResolve.c \
$(GENERIC_DIR)/tclResult.c \
@@ -472,7 +477,8 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclUtil.c \
$(GENERIC_DIR)/tclVar.c \
$(GENERIC_DIR)/tclAssembly.c \
- $(GENERIC_DIR)/tclZlib.c
+ $(GENERIC_DIR)/tclZlib.c \
+ $(GENERIC_DIR)/tclZipfs.c
OO_SRCS = \
$(GENERIC_DIR)/tclOO.c \
@@ -666,6 +672,9 @@ UNIX_SRCS = \
$(UNIX_DIR)/tclUnixCompat.c
NOTIFY_SRCS = \
+ $(UNIX_DIR)/tclEpollNotfy.c \
+ $(UNIX_DIR)/tclKqueueNotfy.c \
+ $(UNIX_DIR)/tclSelectNotfy.c \
$(UNIX_DIR)/tclUnixNotfy.c
DL_SRCS = \
@@ -708,7 +717,46 @@ ZLIB_SRCS = \
# things like "make depend".
SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \
- $(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@ $(TOMMATH_SRCS)
+ $(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@ @TOMMATH_SRCS@
+
+###
+# Tip 430 - ZipFS Modifications
+###
+
+TCL_ZIP_FILE = @TCL_ZIP_FILE@
+TCL_VFS_ROOT = libtcl.vfs
+TCL_VFS_PATH = ${TCL_VFS_ROOT}/tcl_library
+
+HOST_CC = @CC_FOR_BUILD@
+HOST_EXEEXT = @EXEEXT_FOR_BUILD@
+HOST_OBJEXT = @OBJEXT_FOR_BUILD@
+ZIPFS_BUILD = @ZIPFS_BUILD@
+MACHER = @MACHER_PROG@
+NATIVE_ZIP = @ZIP_PROG@
+ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@
+ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@
+SHARED_BUILD = @SHARED_BUILD@
+INSTALL_LIBRARIES = @INSTALL_LIBRARIES@
+INSTALL_MSGS = @INSTALL_MSGS@
+
+# Minizip
+MINIZIP_OBJS = \
+ adler32.$(HOST_OBJEXT) \
+ compress.$(HOST_OBJEXT) \
+ crc32.$(HOST_OBJEXT) \
+ deflate.$(HOST_OBJEXT) \
+ infback.$(HOST_OBJEXT) \
+ inffast.$(HOST_OBJEXT) \
+ inflate.$(HOST_OBJEXT) \
+ inftrees.$(HOST_OBJEXT) \
+ ioapi.$(HOST_OBJEXT) \
+ trees.$(HOST_OBJEXT) \
+ uncompr.$(HOST_OBJEXT) \
+ zip.$(HOST_OBJEXT) \
+ zutil.$(HOST_OBJEXT) \
+ minizip.$(HOST_OBJEXT)
+
+ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
#--------------------------------------------------------------------------
# Start of rules
@@ -722,15 +770,45 @@ libraries:
doc:
+tclzipfile: ${TCL_ZIP_FILE}
+
+${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
+ @rm -rf ${TCL_VFS_ROOT}
+ @mkdir -p ${TCL_VFS_PATH}
+ @echo "creating ${TCL_VFS_PATH} (prepare compression)"
+ @if \
+ ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/; \
+ then : ; else \
+ cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
+ fi
+ mv ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl
+ rm -rf ${TCL_VFS_PATH}/dde ${TCL_VFS_PATH}/registry
+ @find ${TCL_VFS_ROOT} -type d -empty -delete
+ @echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}"
+ @(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \
+ echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?") 2>/dev/null`; \
+ echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \
+ cd ${TCL_VFS_ROOT} && \
+ $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null)
+
# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
-${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS}
+${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
rm -f $@
@MAKE_LIB@
+ @if test "${ZIPFS_BUILD}" = "1" ; then \
+ if test "x$(MACHER)" = "x" ; then \
+ cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
+ else $(MACHER) append ${LIB_FILE} ${TCL_ZIP_FILE} /tmp/macher_output; \
+ mv /tmp/macher_output ${LIB_FILE}; chmod u+x ${LIB_FILE}; \
+ fi; \
+ ${NATIVE_ZIP} -A ${LIB_FILE} \
+ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+ fi
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
- @if test "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \
- (cd ${TOP_DIR}/win; ${MAKE} winextensions); \
+ @if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \
+ ( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \
fi
rm -f $@
@MAKE_STUB_LIB@
@@ -745,10 +823,19 @@ tclLibObjs:
# This targets actually build the objects needed for the lib in the above case
objs: ${OBJS}
-${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE}
+${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${TCL_ZIP_FILE}
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCL_EXE}
+ @if test "${ZIPFS_BUILD}" = "2" ; then \
+ if test "x$(MACHER)" = "x" ; then \
+ cat ${TCL_ZIP_FILE} >> ${TCL_EXE}; \
+ else $(MACHER) append ${TCL_EXE} ${TCL_ZIP_FILE} /tmp/macher_output; \
+ mv /tmp/macher_output ${TCL_EXE}; chmod u+x ${TCL_EXE}; \
+ fi; \
+ ${NATIVE_ZIP} -A ${TCL_EXE} \
+ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+ fi
# Must be empty so it doesn't conflict with rule for ${TCL_EXE} above
${NATIVE_TCLSH}:
@@ -818,14 +905,13 @@ test-tcl: ${TCLTEST_EXE}
$(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS)
gdb-test: ${TCLTEST_EXE}
- @printf '%s ' set env @LD_LIBRARY_PATH_VAR@=\"`pwd`$${@LD_LIBRARY_PATH_VAR@:+:$${@LD_LIBRARY_PATH_VAR}}\" > gdb.run
- @printf '\n' >>gdb.run
- @printf '%s ' set env TCL_LIBRARY=\'$(call shquotesingle,${TCL_BUILDTIME_LIBRARY})\' >> gdb.run
- @printf '\n' >>gdb.run
- @printf '%s ' set args $(call shquotequote,$(TOP_DIR))/tests/all.tcl\
- $(call shquotequote,$(TESTFLAGS)) -singleproc 1 >> gdb.run
- $(GDB) ./${TCLTEST_EXE} --command=gdb.run
- rm gdb.run
+ $(SHELL_ENV) $(GDB) --args ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \
+ $(TESTFLAGS) -singleproc 1
+
+lldb-test: ${TCLTEST_EXE}
+ $(SHELL_ENV) $(LLDB) -- ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl \
+ $(TESTFLAGS) -singleproc 1
+
# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
@@ -866,6 +952,27 @@ valgrind: ${TCL_EXE} ${TCLTEST_EXE}
$(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \
$(TESTFLAGS)
+testresults/valgrind/%.result: ${TCL_EXE} ${TCLTEST_EXE}
+ @mkdir -p testresults/valgrind
+ $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \
+ $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \
+ -file $(basename $(notdir $@)) > $@.tmp 2>&1
+ @mv $@.tmp $@
+.PRECIOUS: testresults/valgrind/%.result
+
+
+testresults/valgrind/%.success: testresults/valgrind/%.result
+ @printf '%s' valgrind >&2
+ @printf ' %s' $(basename $(notdir $@)) >&2
+ @printf '\n >&2'
+ @status=$$(./${TCLTEST_EXE} $(TOP_DIR)/tools/valgrind_check_success \
+ file $(basename $@).result); \
+ if [ "$$status" -eq 1 ]; then touch $@; exit 0; else exit 1; fi
+
+valgrind_each: $(addprefix testresults/valgrind/,$(addsuffix .success,$(notdir\
+ $(wildcard $(TOP_DIR)/tests/*.test))))
+
+
valgrindshell: ${TCL_EXE}
$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCL_EXE} $(SCRIPT)
@@ -879,7 +986,7 @@ trace-test: ${TCLTEST_EXE}
# Installation rules
#--------------------------------------------------------------------------
-INSTALL_BASE_TARGETS = install-binaries install-libraries install-msgs $(INSTALL_TZDATA)
+INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA)
INSTALL_DOC_TARGETS = install-doc
INSTALL_PACKAGE_TARGETS = install-packages
INSTALL_DEV_TARGETS = install-headers
@@ -929,7 +1036,7 @@ install-libraries: libraries
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done;
- @for i in opt0.4 http1.0 encoding; \
+ @for i in opt0.4 cookiejar0.2 encoding; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -937,7 +1044,7 @@ install-libraries: libraries
else true; \
fi; \
done;
- @for i in 8.4 8.4/platform 8.5 8.6; \
+ @for i in 8.4 8.4/platform 8.5 8.6 8.7; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
@@ -949,24 +1056,25 @@ install-libraries: libraries
$(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"
- @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \
+ @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/"
+ @for i in $(TOP_DIR)/library/cookiejar/*.tcl \
+ $(TOP_DIR)/library/cookiejar/*.gz; \
do \
- $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
- @echo "Installing package http 2.9.8 as a Tcl Module";
+ @echo "Installing package http 2.10b1 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
- "$(MODULE_INSTALL_DIR)/8.6/http-2.9.8.tm"
+ "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm"
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"
@for i in $(TOP_DIR)/library/opt/*.tcl; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done
- @echo "Installing package msgcat 1.6.1 as a Tcl Module"
+ @echo "Installing package msgcat 1.7.1 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
- "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"
- @echo "Installing package tcltest 2.5.5 as a Tcl Module"
+ "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm"
+ @echo "Installing package tcltest 2.5.6 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
- "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm"
+ "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm"
@echo "Installing package platform 1.0.19 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm"
@@ -1047,6 +1155,19 @@ install-doc: doc
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \
done
+# Public headers that define Tcl's API
+TCL_PUBLIC_HEADERS = $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
+ $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \
+ $(GENERIC_DIR)/tclPlatDecls.h $(GENERIC_DIR)/tclTomMath.h \
+ $(GENERIC_DIR)/tclTomMathDecls.h
+# Private headers that define Tcl's internal API
+TCL_PRIVATE_HEADERS = $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
+ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \
+ $(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \
+ $(UNIX_DIR)/tclUnixPort.h
+# Any other headers you find in the Tcl sources are purely part of Tcl's
+# implementation, and aren't to be installed.
+
install-headers:
@for i in "$(INCLUDE_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
@@ -1055,12 +1176,7 @@ install-headers:
fi; \
done
@echo "Installing header files to $(INCLUDE_INSTALL_DIR)/";
- @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
- $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \
- $(GENERIC_DIR)/tclPlatDecls.h \
- $(GENERIC_DIR)/tclTomMath.h \
- $(GENERIC_DIR)/tclTomMathDecls.h ; \
- do \
+ @for i in $(TCL_PUBLIC_HEADERS); do \
$(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \
done
@@ -1073,11 +1189,7 @@ install-private-headers:
fi; \
done
@echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/";
- @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
- $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \
- $(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \
- $(UNIX_DIR)/tclUnixPort.h; \
- do \
+ @for i in $(TCL_PRIVATE_HEADERS); do \
$(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
done
@if test -f tclConfig.h; then\
@@ -1133,7 +1245,7 @@ TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h
COMPILEHDR = $(GENERIC_DIR)/tclCompile.h
FSHDR = $(GENERIC_DIR)/tclFileSystem.h
IOHDR = $(GENERIC_DIR)/tclIO.h
-MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tommath.h
+MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
@@ -1161,6 +1273,9 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c
tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c
+tclArithSeries.o: $(GENERIC_DIR)/tclArithSeries.c $(COMPILEHDR)
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclArithSeries.c
+
tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c
@@ -1323,7 +1438,7 @@ tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
tclNotify.o: $(GENERIC_DIR)/tclNotify.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c
-tclOO.o: $(GENERIC_DIR)/tclOO.c
+tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c
tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c
@@ -1391,6 +1506,9 @@ tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c
tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c
+tclProcess.o: $(GENERIC_DIR)/tclProcess.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c
+
tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c
@@ -1427,7 +1545,14 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c
tclZlib.o: $(GENERIC_DIR)/tclZlib.c
$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c
-tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS)
+tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c
+ $(CC) -c $(CC_SWITCHES) -D_GNU_SOURCE \
+ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \
+ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \
+ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \
+ $(GENERIC_DIR)/tclZipfs.c
+
+tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h
$(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c
tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS)
@@ -1523,6 +1648,9 @@ bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(MATHHDRS)
bn_mp_expt_u32.o: $(TOMMATH_DIR)/bn_mp_expt_u32.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_u32.c
+bn_mp_get_mag_u64.o: $(TOMMATH_DIR)/bn_mp_get_mag_u64.c $(MATHHDRS)
+ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_mag_u64.c
+
bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c
@@ -1532,6 +1660,9 @@ bn_mp_init.o: $(TOMMATH_DIR)/bn_mp_init.c $(MATHHDRS)
bn_mp_init_copy.o: $(TOMMATH_DIR)/bn_mp_init_copy.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_copy.c
+bn_mp_init_i64.o:$(TOMMATH_DIR)/bn_mp_init_i64.c $(MATHHDRS)
+ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_i64.c
+
bn_mp_init_multi.o: $(TOMMATH_DIR)/bn_mp_init_multi.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_multi.c
@@ -1541,6 +1672,9 @@ bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c $(MATHHDRS)
bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c
+bn_mp_init_u64.o:$(TOMMATH_DIR)/bn_mp_init_u64.c $(MATHHDRS)
+ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_u64.c
+
bn_s_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c
@@ -1595,8 +1729,11 @@ bn_mp_read_radix.o: $(TOMMATH_DIR)/bn_mp_read_radix.c $(MATHHDRS)
bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_rshd.c
-bn_mp_set.o: $(TOMMATH_DIR)/bn_mp_set.c $(MATHHDRS)
- $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set.c
+bn_mp_set_i64.o: $(TOMMATH_DIR)/bn_mp_set_i64.c $(MATHHDRS)
+ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_i64.c
+
+bn_mp_set_u64.o: $(TOMMATH_DIR)/bn_mp_set_u64.c $(MATHHDRS)
+ $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_u64.c
bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c
@@ -1664,8 +1801,14 @@ tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c
tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c $(FSHDR)
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c
-tclUnixNotfy.o: $(UNIX_DIR)/tclUnixNotfy.c
- $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixNotfy.c
+tclEpollNotfy.o: $(UNIX_DIR)/tclEpollNotfy.c $(UNIX_DIR)/tclUnixNotfy.c
+ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclEpollNotfy.c
+
+tclKqueueNotfy.o: $(UNIX_DIR)/tclKqueueNotfy.c $(UNIX_DIR)/tclUnixNotfy.c
+ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclKqueueNotfy.c
+
+tclSelectNotfy.o: $(UNIX_DIR)/tclSelectNotfy.c $(UNIX_DIR)/tclUnixNotfy.c
+ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclSelectNotfy.c
tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c
@@ -1807,13 +1950,64 @@ tclOOStubLib.o: $(GENERIC_DIR)/tclOOStubLib.c
$(CC) -c $(CC_SWITCHES) $<
#--------------------------------------------------------------------------
+# Minizip implementation
+#--------------------------------------------------------------------------
+adler32.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c
+
+compress.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c
+
+crc32.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c
+
+deflate.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c
+
+ioapi.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \
+ $(ZLIB_DIR)/contrib/minizip/ioapi.c
+
+infback.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c
+
+inffast.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c
+
+inflate.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c
+
+inftrees.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c
+
+trees.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c
+
+uncompr.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c
+
+zip.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \
+ $(ZLIB_DIR)/contrib/minizip/zip.c
+
+zutil.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c
+
+minizip.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -DIOAPI_NO_64 -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c \
+ $(ZLIB_DIR)/contrib/minizip/minizip.c
+
+minizip${HOST_EXEEXT}: $(MINIZIP_OBJS)
+ $(HOST_CC) -o $@ $(MINIZIP_OBJS)
+
+#--------------------------------------------------------------------------
# Bundled Package targets
#--------------------------------------------------------------------------
# Propagate configure args like --enable-64bit to package configure
PKG_CFG_ARGS = @PKG_CFG_ARGS@
# If PKG_DIR is changed to a different relative depth to the build dir, need
-# to adapt the ../.. relative paths below and at the top of configure.in (we
+# to adapt the ../.. relative paths below and at the top of configure.ac (we
# cannot use absolute paths due to issues in nested configure when path to
# build dir contains spaces).
PKG_DIR = ./pkgs
@@ -1830,7 +2024,7 @@ configure-packages:
$$i/configure --with-tcl=../.. \
--with-tclinclude=$(GENERIC_DIR) \
$(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \
- --enable-shared --enable-threads; ) || exit $$?; \
+ --enable-shared; ) || exit $$?; \
fi; \
fi; \
fi; \
@@ -1936,14 +2130,6 @@ gendate:
# <y.tab.c >$(GENERIC_DIR)/tclDate.c
# rm y.tab.c
-# The following target generates the file generic/tclTomMath.h. It needs to be
-# run (and the results checked) after updating to a new release of libtommath.
-
-gentommath_h:
- $(NATIVE_TCLSH) "$(TOOL_DIR)/fix_tommath_h.tcl" \
- "$(TOMMATH_DIR)/tommath.h" \
- > "$(GENERIC_DIR)/tclTomMath.h"
-
#
# Target to regenerate header files and stub files from the *.decls tables.
#
@@ -1959,6 +2145,11 @@ $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
+$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
+ @echo "Warning: tclOOScript.h may be out of date."
+ @echo "Developers may want to run \"make genscript\" to regenerate."
+ @echo "This warning can be safely ignored, do not report as a bug!"
+
genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
@@ -1966,6 +2157,10 @@ genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tclOO.decls
+genscript:
+ $(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \
+ $(TOOL_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h
+
#
# Target to check that all exported functions have an entry in the stubs
# tables.
@@ -2054,9 +2249,9 @@ DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
-BUILTIN_PACKAGE_LIST = http1.0 http opt msgcat reg dde tcltest platform
+BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat registry dde tcltest platform
-$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4 \
+$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \
$(UNIX_DIR)/aclocal.m4
cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
@@ -2084,7 +2279,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
cp -p $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
- cp -p $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \
+ cp -p $(UNIX_DIR)/configure $(UNIX_DIR)/configure.ac \
$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
$(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/tclooConfig.sh \
$(UNIX_DIR)/install-sh \
@@ -2103,11 +2298,13 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
$(DISTDIR)
@mkdir $(DISTDIR)/library
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
+ $(TOP_DIR)/library/manifest.txt \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
@for i in $(BUILTIN_PACKAGE_LIST); do \
mkdir $(DISTDIR)/library/$$i;\
cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
done
+ cp -p $(TOP_DIR)/library/cookiejar/*.dat.gz $(DISTDIR)/library/cookiejar
@mkdir $(DISTDIR)/library/encoding
cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
@mkdir $(DISTDIR)/library/msgs
@@ -2128,12 +2325,15 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
| ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
| ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
@mkdir $(DISTDIR)/libtommath
- cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath
+ @echo cp -r $(TOP_DIR)/libtommath $(DISTDIR)/libtommath
+ @( cd $(TOP_DIR)/libtommath; find . -type f -print ) \
+ | ( cd $(TOP_DIR)/libtommath ; xargs tar cf - ) \
+ | ( cd $(DISTDIR)/libtommath ; tar xfp - )
@mkdir $(DISTDIR)/tests
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests
cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
- $(DISTDIR)/tests
+ $(TOP_DIR)/tests/auto-files.zip $(DISTDIR)/tests
@mkdir $(DISTDIR)/tests/auto0
for i in auto1 auto2 ; \
do \
@@ -2149,7 +2349,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
done;
@mkdir $(DISTDIR)/win
cp -p $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
- cp -p $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \
+ cp -p $(TOP_DIR)/win/configure.ac $(TOP_DIR)/win/configure \
$(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \
$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
$(TOP_DIR)/win/tclsh.exe.manifest.in $(TOP_DIR)/win/tclUuid.h.in \
@@ -2160,8 +2360,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
$(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.vc $(DISTDIR)/win
- cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win
- cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win
cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win
cp -p $(TOP_DIR)/win/README $(DISTDIR)/win
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win
@@ -2171,10 +2369,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
$(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \
$(MAC_OSX_DIR)/configure $(DISTDIR)/macosx
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx
- @mkdir $(DISTDIR)/macosx/Tcl.xcode
- cp -p $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \
- $(MAC_OSX_DIR)/Tcl.xcode/default.pbxuser \
- $(DISTDIR)/macosx/Tcl.xcode
@mkdir $(DISTDIR)/macosx/Tcl.xcodeproj
cp -p $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \
$(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \
@@ -2183,11 +2377,9 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \
$(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest
@mkdir $(DISTDIR)/tools
- cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \
- $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \
- $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \
- $(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \
- $(DISTDIR)/tools
+ cp -p $(TOOL_DIR)/README $(TOOL_DIR)/*.c $(TOOL_DIR)/*.svg \
+ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/*.bmp \
+ $(TOOL_DIR)/valgrind_suppress $(DISTDIR)/tools
@mkdir $(DISTDIR)/pkgs
cp -p $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs
cp -p $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs
@@ -2232,13 +2424,11 @@ html-tk: ${NATIVE_TCLSH}
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
-# You'd better have these programs or you will have problems creating Makefile
-# from Makefile.in in the first place...
-HTML_VERSION = `basename $(TOP_DIR) | sed s/tcl//`
BUILD_HTML = \
@${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \
- --useversion=$(HTML_VERSION) --htmldir="$(HTML_INSTALL_DIR)" \
- --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS)
+ --useversion=$(MAJOR_VERSION).$(MINOR_VERSION) \
+ --htmldir="$(HTML_INSTALL_DIR)" \
+ --srcdir=$(TOP_DIR) $(BUILD_HTML_FLAGS)
#--------------------------------------------------------------------------
# The list of all the targets that do not correspond to real files. This stops
@@ -2255,6 +2445,7 @@ BUILD_HTML = \
.PHONY: install-tzdata install-msgs
.PHONY: packages configure-packages test-packages clean-packages
.PHONY: dist-packages distclean-packages install-packages
+.PHONY: tclzipfile
#--------------------------------------------------------------------------
# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/unix/README b/unix/README
index a3180c9..9dad93a 100644
--- a/unix/README
+++ b/unix/README
@@ -45,8 +45,6 @@ How To Compile And Install Tcl:
refer to the autoconf documentation (not included here). Tcl's "configure"
supports the following special switches in addition to the standard ones:
- --enable-threads If this switch is set, Tcl will compile itself
- with multithreading support.
--disable-load If this switch is specified then Tcl will
configure itself not to allow dynamic loading,
even if your system appears to support it.
@@ -93,7 +91,7 @@ How To Compile And Install Tcl:
for descriptions of the probes made available,
see https://wiki.tcl-lang.org/page/DTrace for more details
--with-encoding=ENCODING Specifies the encoding for compile-time
- configuration values. Defaults to iso8859-1,
+ configuration values. Defaults to utf-8,
which is also sufficient for ASCII.
--with-tzdata=FLAG Specifies whether to install timezone data. By
default, the configure script tries to detect
diff --git a/unix/configure b/unix/configure
index 54e3ae6..05fd35a 100755
--- a/unix/configure
+++ b/unix/configure
@@ -1,81 +1,479 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.59 for tcl 8.6.
+# Generated by GNU Autoconf 2.71 for tcl 8.7.
+#
+#
+# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation,
+# Inc.
+#
#
-# 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. ##
-## --------------------- ##
+## -------------------- ##
+## M4sh Initialization. ##
+## -------------------- ##
-# Be Bourne compatible
-if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+as_nop=:
+if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
+then :
emulate sh
NULLCMD=:
- # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # Pre-4.2 versions of Zsh do 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
+ setopt NO_GLOB_SUBST
+else $as_nop
+ case `(set -o) 2>/dev/null` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
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
+# Reset variables that may have inherited troublesome values from
+# the environment.
+
+# IFS needs to be set, to space, tab, and newline, in precisely that order.
+# (If _AS_PATH_WALK were called with IFS unset, it would have the
+# side effect of setting IFS to empty, thus disabling word splitting.)
+# Quoting is to prevent editors from complaining about space-tab.
+as_nl='
+'
+export as_nl
+IFS=" "" $as_nl"
+
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
+# Ensure predictable behavior from utilities with locale-dependent output.
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# We cannot yet rely on "unset" to work, but we need these variables
+# to be unset--not just set to an empty or harmless value--now, to
+# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
+# also avoids known problems related to "unset" and subshell syntax
+# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
+for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
+do eval test \${$as_var+y} \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
+
+# Ensure that fds 0, 1, and 2 are open.
+if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
+if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
+if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
+
+# The user is always right.
+if ${PATH_SEPARATOR+false} :; then
+ PATH_SEPARATOR=:
+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
+ PATH_SEPARATOR=';'
+ }
+fi
+
+
+# Find who we are. Look in the path if we contain no directory separator.
+as_myself=
+case $0 in #((
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
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
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ test -r "$as_dir$0" && as_myself=$as_dir$0 && break
+ done
+IFS=$as_save_IFS
+
+ ;;
+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
+ printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+
+# Use a proper internal environment variable to ensure we don't fall
+ # into an infinite loop, continuously re-executing ourselves.
+ if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
+ _as_can_reexec=no; export _as_can_reexec;
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
fi
+ # We don't want this to propagate to other subprocesses.
+ { _as_can_reexec=; unset _as_can_reexec;}
+if test "x$CONFIG_SHELL" = x; then
+ as_bourne_compatible="as_nop=:
+if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
+then :
+ emulate sh
+ NULLCMD=:
+ # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '\${1+\"\$@\"}'='\"\$@\"'
+ setopt NO_GLOB_SUBST
+else \$as_nop
+ case \`(set -o) 2>/dev/null\` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
+fi
+"
+ as_required="as_fn_return () { (exit \$1); }
+as_fn_success () { as_fn_return 0; }
+as_fn_failure () { as_fn_return 1; }
+as_fn_ret_success () { return 0; }
+as_fn_ret_failure () { return 1; }
+
+exitcode=0
+as_fn_success || { exitcode=1; echo as_fn_success failed.; }
+as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }
+as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }
+as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }
+if ( set x; as_fn_ret_success y && test x = \"\$1\" )
+then :
+
+else \$as_nop
+ exitcode=1; echo positional parameters were not saved.
+fi
+test x\$exitcode = x0 || exit 1
+blah=\$(echo \$(echo blah))
+test x\"\$blah\" = xblah || exit 1
+test -x / || exit 1"
+ as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
+ as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
+ eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
+ test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1
+test \$(( 1 + 1 )) = 2 || exit 1"
+ if (eval "$as_required") 2>/dev/null
+then :
+ as_have_required=yes
+else $as_nop
+ as_have_required=no
+fi
+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null
+then :
+
+else $as_nop
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+as_found=false
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ as_found=:
+ case $as_dir in #(
+ /*)
+ for as_base in sh bash ksh sh5; do
+ # Try only shells that exist, to save several forks.
+ as_shell=$as_dir$as_base
+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
+ as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null
+then :
+ CONFIG_SHELL=$as_shell as_have_required=yes
+ if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null
+then :
+ break 2
+fi
+fi
+ done;;
+ esac
+ as_found=false
done
+IFS=$as_save_IFS
+if $as_found
+then :
+
+else $as_nop
+ if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
+ as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null
+then :
+ CONFIG_SHELL=$SHELL as_have_required=yes
+fi
+fi
+
+
+ if test "x$CONFIG_SHELL" != x
+then :
+ export CONFIG_SHELL
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
+fi
+
+ if test x$as_have_required = xno
+then :
+ printf "%s\n" "$0: This script requires a shell more modern than all"
+ printf "%s\n" "$0: the shells that I found on your system."
+ if test ${ZSH_VERSION+y} ; then
+ printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should"
+ printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later."
+ else
+ printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system,
+$0: including any error possibly output before this
+$0: message. Then install a modern shell, or manually run
+$0: the script under such a shell if you do have one."
+ fi
+ exit 1
+fi
+fi
+fi
+SHELL=${CONFIG_SHELL-/bin/sh}
+export SHELL
+# Unset more variables known to interfere with behavior of common tools.
+CLICOLOR_FORCE= GREP_OPTIONS=
+unset CLICOLOR_FORCE GREP_OPTIONS
+
+## --------------------- ##
+## M4sh Shell Functions. ##
+## --------------------- ##
+# as_fn_unset VAR
+# ---------------
+# Portably unset VAR.
+as_fn_unset ()
+{
+ { eval $1=; unset $1;}
+}
+as_unset=as_fn_unset
+
+
+# as_fn_set_status STATUS
+# -----------------------
+# Set $? to STATUS, without forking.
+as_fn_set_status ()
+{
+ return $1
+} # as_fn_set_status
+
+# as_fn_exit STATUS
+# -----------------
+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
+as_fn_exit ()
+{
+ set +e
+ as_fn_set_status $1
+ exit $1
+} # as_fn_exit
+# as_fn_nop
+# ---------
+# Do nothing but, unlike ":", preserve the value of $?.
+as_fn_nop ()
+{
+ return $?
+}
+as_nop=as_fn_nop
+
+# as_fn_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
+
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || eval $as_mkdir_p || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
+
+
+} # as_fn_mkdir_p
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
+# as_fn_append VAR VALUE
+# ----------------------
+# Append the text in VALUE to the end of the definition contained in VAR. Take
+# advantage of any shell optimizations that allow amortized linear growth over
+# repeated appends, instead of the typical quadratic growth present in naive
+# implementations.
+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
+then :
+ eval 'as_fn_append ()
+ {
+ eval $1+=\$2
+ }'
+else $as_nop
+ as_fn_append ()
+ {
+ eval $1=\$$1\$2
+ }
+fi # as_fn_append
+
+# as_fn_arith ARG...
+# ------------------
+# Perform arithmetic evaluation on the ARGs, and store the result in the
+# global $as_val. Take advantage of shells that can avoid forks. The arguments
+# must be portable across $(()) and expr.
+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
+then :
+ eval 'as_fn_arith ()
+ {
+ as_val=$(( $* ))
+ }'
+else $as_nop
+ as_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+# as_fn_nop
+# ---------
+# Do nothing but, unlike ":", preserve the value of $?.
+as_fn_nop ()
+{
+ return $?
+}
+as_nop=as_fn_nop
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
+# as_fn_error STATUS ERROR [LINENO LOG_FD]
+# ----------------------------------------
+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
+# script with STATUS, using 1 if that was 0.
+as_fn_error ()
+{
+ as_status=$1; test $as_status -eq 0 && as_status=1
+ if test "$4"; then
+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ printf "%s\n" "$as_me: error: $2" >&2
+ as_fn_exit $as_status
+} # as_fn_error
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
-if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
-# Name of the executable.
-as_me=`$as_basename "$0" ||
+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'`
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" 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'
@@ -83,146 +481,102 @@ 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 |
+ as_lineno_1=$LINENO as_lineno_1a=$LINENO
+ as_lineno_2=$LINENO as_lineno_2a=$LINENO
+ eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&
+ test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {
+ # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
N
- s,$,-,
- : loop
- s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3,
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
- s,-$,,
- s,^['$as_cr_digits']*\n,,
+ s/-\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; }; }
+ chmod +x "$as_me.lineno" ||
+ { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
+ # If we had to re-execute with $CONFIG_SHELL, we're ensured to have
+ # already done that, so ensure we don't try to do so again and fall
+ # in an infinite loop. This has already happened in practice.
+ _as_can_reexec=no; export _as_can_reexec
# 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
+ # original and so on. Autoconf is especially sensitive 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= ;;
+# Determine whether it's possible to make 'echo' print without a newline.
+# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
+# for compatibility with existing Makefiles.
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in #(((((
+-n*)
+ case `echo 'xy\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ xy) ECHO_C='\c';;
+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
+ ECHO_T=' ';;
+ esac;;
+*)
+ ECHO_N='-n';;
esac
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
+# For backward compatibility with old third-party macros, we provide
+# the shell variables $as_echo and $as_echo_n. New code should use
+# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
+as_echo='printf %s\n'
+as_echo_n='printf %s'
+
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
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
+fi
+if (echo >conf$$.file) 2>/dev/null; then
+ if ln -s conf$$.file conf$$ 2>/dev/null; then
as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -pR'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -pR'
+ elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+ else
+ as_ln_s='cp -pR'
fi
-elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
-rm -f conf$$ conf$$.exe conf$$.file
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
- as_mkdir_p=:
+ as_mkdir_p='mkdir -p "$as_dir"'
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
-as_executable_p="test -f"
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# 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'"
@@ -231,89 +585,252 @@ as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
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
-
+test -n "$DJDIR" || exec 7<&0 </dev/null
+exec 6>&1
# Name of the host.
-# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
+# hostname on some systems (SVR3.2, old GNU/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_clean_files=
ac_config_libobj_dir=.
+LIBOBJS=
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='tcl'
PACKAGE_TARNAME='tcl'
-PACKAGE_VERSION='8.6'
-PACKAGE_STRING='tcl 8.6'
+PACKAGE_VERSION='8.7'
+PACKAGE_STRING='tcl 8.7'
PACKAGE_BUGREPORT=''
+PACKAGE_URL=''
# Factoring default headers for most tests.
ac_includes_default="\
-#include <stdio.h>
-#if HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#endif
-#if HAVE_SYS_STAT_H
-# include <sys/stat.h>
+#include <stddef.h>
+#ifdef HAVE_STDIO_H
+# include <stdio.h>
#endif
-#if STDC_HEADERS
+#ifdef HAVE_STDLIB_H
# include <stdlib.h>
-# include <stddef.h>
-#else
-# if HAVE_STDLIB_H
-# include <stdlib.h>
-# endif
#endif
-#if HAVE_STRING_H
-# if !STDC_HEADERS && HAVE_MEMORY_H
-# include <memory.h>
-# endif
+#ifdef HAVE_STRING_H
# include <string.h>
#endif
-#if HAVE_STRINGS_H
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#endif
+#ifdef HAVE_STRINGS_H
# include <strings.h>
#endif
-#if HAVE_INTTYPES_H
-# include <inttypes.h>
-#else
-# if HAVE_STDINT_H
-# include <stdint.h>
-# endif
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
#endif
-#if HAVE_UNISTD_H
+#ifdef HAVE_SYS_STAT_H
+# include <sys/stat.h>
+#endif
+#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif"
-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 MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS SHARED_BUILD TCLSH_PROG ZLIB_OBJS ZLIB_SRCS ZLIB_INCLUDE RANLIB ac_ct_RANLIB AR ac_ct_AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS LDAIX_SRC CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_NOLTO LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB DLL_INSTALL_DIR INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT DTRACE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR PKG_CFG_ARGS TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG INSTALL_TZDATA DTRACE_SRC DTRACE_HDR DTRACE_OBJ MAKEFILE_SHELL BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR PACKAGE_DIR EXTRA_CC_SWITCHES EXTRA_APP_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML EXTRA_TCLSH_LIBS DLTEST_LD DLTEST_SUFFIX'
+ac_header_c_list=
+ac_subst_vars='DLTEST_SUFFIX
+DLTEST_LD
+EXTRA_TCLSH_LIBS
+EXTRA_BUILD_HTML
+EXTRA_INSTALL_BINARIES
+EXTRA_INSTALL
+EXTRA_APP_CC_SWITCHES
+EXTRA_CC_SWITCHES
+PACKAGE_DIR
+HTML_DIR
+PRIVATE_INCLUDE_DIR
+TCL_LIBRARY
+TCL_MODULE_PATH
+TCL_PACKAGE_PATH
+BUILD_DLTEST
+MAKEFILE_SHELL
+DTRACE_OBJ
+DTRACE_HDR
+DTRACE_SRC
+INSTALL_TZDATA
+TCL_HAS_LONGLONG
+TCL_UNSHARED_LIB_SUFFIX
+TCL_SHARED_LIB_SUFFIX
+TCL_LIB_VERSIONS_OK
+TCL_BUILD_LIB_SPEC
+LD_LIBRARY_PATH_VAR
+TCL_SHARED_BUILD
+CFG_TCL_UNSHARED_LIB_SUFFIX
+CFG_TCL_SHARED_LIB_SUFFIX
+TCL_SRC_DIR
+TCL_BUILD_STUB_LIB_PATH
+TCL_BUILD_STUB_LIB_SPEC
+TCL_INCLUDE_SPEC
+TCL_STUB_LIB_PATH
+TCL_STUB_LIB_SPEC
+TCL_STUB_LIB_FLAG
+TCL_STUB_LIB_FILE
+TCL_LIB_SPEC
+TCL_LIB_FLAG
+TCL_LIB_FILE
+PKG_CFG_ARGS
+TCL_YEAR
+TCL_PATCH_LEVEL
+TCL_MINOR_VERSION
+TCL_MAJOR_VERSION
+TCL_VERSION
+INSTALL_MSGS
+INSTALL_LIBRARIES
+TCL_ZIP_FILE
+ZIPFS_BUILD
+ZIP_INSTALL_OBJS
+ZIP_PROG_VFSSEARCH
+ZIP_PROG_OPTIONS
+ZIP_PROG
+MACHER_PROG
+EXEEXT_FOR_BUILD
+CC_FOR_BUILD
+DTRACE
+LDFLAGS_DEFAULT
+CFLAGS_DEFAULT
+INSTALL_STUB_LIB
+DLL_INSTALL_DIR
+INSTALL_LIB
+MAKE_STUB_LIB
+MAKE_LIB
+SHLIB_SUFFIX
+SHLIB_CFLAGS
+SHLIB_LD_LIBS
+TK_SHLIB_LD_EXTRAS
+TCL_SHLIB_LD_EXTRAS
+SHLIB_LD
+STLIB_LD
+LD_SEARCH_FLAGS
+CC_SEARCH_FLAGS
+LDFLAGS_OPTIMIZE
+LDFLAGS_DEBUG
+CFLAGS_NOLTO
+CFLAGS_WARNING
+CFLAGS_OPTIMIZE
+CFLAGS_DEBUG
+LDAIX_SRC
+PLAT_SRCS
+PLAT_OBJS
+DL_OBJS
+DL_LIBS
+TCL_LIBS
+LIBOBJS
+AR
+RANLIB
+TOMMATH_INCLUDE
+TOMMATH_SRCS
+TOMMATH_OBJS
+ZLIB_INCLUDE
+ZLIB_SRCS
+ZLIB_OBJS
+TCLSH_PROG
+SHARED_BUILD
+EGREP
+GREP
+CPP
+OBJEXT
+EXEEXT
+ac_ct_CC
+CPPFLAGS
+LDFLAGS
+CFLAGS
+CC
+MAN_FLAGS
+target_alias
+host_alias
+build_alias
+LIBS
+ECHO_T
+ECHO_N
+ECHO_C
+DEFS
+mandir
+localedir
+libdir
+psdir
+pdfdir
+dvidir
+htmldir
+infodir
+docdir
+oldincludedir
+includedir
+runstatedir
+localstatedir
+sharedstatedir
+sysconfdir
+datadir
+datarootdir
+libexecdir
+sbindir
+bindir
+program_transform_name
+prefix
+exec_prefix
+PACKAGE_URL
+PACKAGE_BUGREPORT
+PACKAGE_STRING
+PACKAGE_VERSION
+PACKAGE_TARNAME
+PACKAGE_NAME
+PATH_SEPARATOR
+SHELL
+OBJEXT_FOR_BUILD'
ac_subst_files=''
+ac_user_opts='
+enable_option_checking
+enable_man_symlinks
+enable_man_compression
+enable_man_suffix
+with_encoding
+enable_shared
+with_system_libtommath
+enable_64bit
+enable_64bit_vis
+enable_rpath
+enable_corefoundation
+enable_load
+enable_symbols
+enable_langinfo
+enable_dll_unloading
+with_tzdata
+enable_dtrace
+enable_framework
+enable_zipfs
+'
+ ac_precious_vars='build_alias
+host_alias
+target_alias
+CC
+CFLAGS
+LDFLAGS
+LIBS
+CPPFLAGS
+CPP'
+
# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
+ac_unrecognized_opts=
+ac_unrecognized_sep=
# The variables have the same names as the options, with
# dashes changed to underlines.
cache_file=/dev/null
@@ -336,34 +853,48 @@ x_libraries=NONE
# 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.
+# (The list follows the same order as the GNU Coding Standards.)
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
+datarootdir='${prefix}/share'
+datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
+runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
+docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
+infodir='${datarootdir}/info'
+htmldir='${docdir}'
+dvidir='${docdir}'
+pdfdir='${docdir}'
+psdir='${docdir}'
+libdir='${exec_prefix}/lib'
+localedir='${datarootdir}/locale'
+mandir='${datarootdir}/man'
ac_prev=
+ac_dashdash=
for ac_option
do
# If the previous option needs an argument, assign it.
if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
+ 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
+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *=) ac_optarg= ;;
+ *) ac_optarg=yes ;;
+ esac
+
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
@@ -385,33 +916,59 @@ do
--config-cache | -C)
cache_file=config.cache ;;
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
+ -datadir | --datadir | --datadi | --datad)
ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
+ -datadir=* | --datadir=* | --datadi=* | --datad=*)
datadir=$ac_optarg ;;
+ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
+ | --dataroo | --dataro | --datar)
+ ac_prev=datarootdir ;;
+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
+ datarootdir=$ac_optarg ;;
+
-disable-* | --disable-*)
- ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
+ ac_useropt=`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" ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid feature name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"enable_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval enable_$ac_useropt=no ;;
+
+ -docdir | --docdir | --docdi | --doc | --do)
+ ac_prev=docdir ;;
+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
+ docdir=$ac_optarg ;;
+
+ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
+ ac_prev=dvidir ;;
+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
+ dvidir=$ac_optarg ;;
-enable-* | --enable-*)
- ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
+ ac_useropt=`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 ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid feature name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"enable_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
esac
- eval "enable_$ac_feature='$ac_optarg'" ;;
+ eval enable_$ac_useropt=\$ac_optarg ;;
-exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
| --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
@@ -438,6 +995,12 @@ do
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
+ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
+ ac_prev=htmldir ;;
+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
+ | --ht=*)
+ htmldir=$ac_optarg ;;
+
-includedir | --includedir | --includedi | --included | --include \
| --includ | --inclu | --incl | --inc)
ac_prev=includedir ;;
@@ -462,13 +1025,16 @@ do
| --libexe=* | --libex=* | --libe=*)
libexecdir=$ac_optarg ;;
+ -localedir | --localedir | --localedi | --localed | --locale)
+ ac_prev=localedir ;;
+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
+ localedir=$ac_optarg ;;
+
-localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
+ | --localstate | --localstat | --localsta | --localst | --locals)
ac_prev=localstatedir ;;
-localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
localstatedir=$ac_optarg ;;
-mandir | --mandir | --mandi | --mand | --man | --ma | --m)
@@ -533,10 +1099,29 @@ do
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
+ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
+ ac_prev=pdfdir ;;
+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
+ pdfdir=$ac_optarg ;;
+
+ -psdir | --psdir | --psdi | --psd | --ps)
+ ac_prev=psdir ;;
+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
+ psdir=$ac_optarg ;;
+
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
+ -runstatedir | --runstatedir | --runstatedi | --runstated \
+ | --runstate | --runstat | --runsta | --runst | --runs \
+ | --run | --ru | --r)
+ ac_prev=runstatedir ;;
+ -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
+ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
+ | --run=* | --ru=* | --r=*)
+ runstatedir=$ac_optarg ;;
+
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
@@ -583,26 +1168,36 @@ do
ac_init_version=: ;;
-with-* | --with-*)
- ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
+ ac_useropt=`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 ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid package name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"with_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
esac
- eval "with_$ac_package='$ac_optarg'" ;;
+ eval with_$ac_useropt=\$ac_optarg ;;
-without-* | --without-*)
- ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
+ ac_useropt=`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" ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid package name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"with_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval with_$ac_useropt=no ;;
--x)
# Obsolete; use --with-x.
@@ -622,27 +1217,26 @@ do
| --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; }; }
+ -*) as_fn_error $? "unrecognized option: \`$ac_option'
+Try \`$0 --help' for more information"
;;
*=*)
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'"
+ case $ac_envvar in #(
+ '' | [0-9]* | *[!_$as_cr_alnum]* )
+ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
+ esac
+ 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
+ printf "%s\n" "$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}
+ printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
@@ -650,31 +1244,36 @@ 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; }; }
+ as_fn_error $? "missing argument to $ac_option"
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; }; };;
+if test -n "$ac_unrecognized_opts"; then
+ case $enable_option_checking in
+ no) ;;
+ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;
+ *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;
esac
-done
+fi
-# Be sure to have absolute paths.
-for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
- localstatedir libdir includedir oldincludedir infodir mandir
+# Check all directory arguments for consistency.
+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
+ datadir sysconfdir sharedstatedir localstatedir includedir \
+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
+ libdir localedir mandir runstatedir
do
- eval ac_val=$`echo $ac_var`
+ eval ac_val=\$$ac_var
+ # Remove trailing slashes.
case $ac_val in
- [\\/$]* | ?:[\\/]* ) ;;
- *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
- { (exit 1); exit 1; }; };;
+ */ )
+ ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`
+ eval $ac_var=\$ac_val;;
esac
+ # Be sure to have absolute directory names.
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* ) continue;;
+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
+ esac
+ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"
done
# There might be people who depend on the old broken behavior: `$host'
@@ -688,8 +1287,6 @@ target=$target_alias
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
@@ -701,74 +1298,72 @@ test -n "$host_alias" && ac_tool_prefix=$host_alias-
test "$silent" = yes && exec 6>/dev/null
+ac_pwd=`pwd` && test -n "$ac_pwd" &&
+ac_ls_di=`ls -di .` &&
+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
+ as_fn_error $? "working directory cannot be determined"
+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
+ as_fn_error $? "pwd does not report name of working directory"
+
+
# 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'`
+ # Try the directory containing this script, then the parent directory.
+ ac_confdir=`$as_dirname -- "$as_myself" ||
+$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_myself" : 'X\(//\)[^/]' \| \
+ X"$as_myself" : 'X\(//\)$' \| \
+ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$as_myself" |
+ 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
+ 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
-ac_env_CC_set=${CC+set}
-ac_env_CC_value=$CC
-ac_cv_env_CC_set=${CC+set}
-ac_cv_env_CC_value=$CC
-ac_env_CFLAGS_set=${CFLAGS+set}
-ac_env_CFLAGS_value=$CFLAGS
-ac_cv_env_CFLAGS_set=${CFLAGS+set}
-ac_cv_env_CFLAGS_value=$CFLAGS
-ac_env_LDFLAGS_set=${LDFLAGS+set}
-ac_env_LDFLAGS_value=$LDFLAGS
-ac_cv_env_LDFLAGS_set=${LDFLAGS+set}
-ac_cv_env_LDFLAGS_value=$LDFLAGS
-ac_env_CPPFLAGS_set=${CPPFLAGS+set}
-ac_env_CPPFLAGS_value=$CPPFLAGS
-ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set}
-ac_cv_env_CPPFLAGS_value=$CPPFLAGS
-ac_env_CPP_set=${CPP+set}
-ac_env_CPP_value=$CPP
-ac_cv_env_CPP_set=${CPP+set}
-ac_cv_env_CPP_value=$CPP
+if test ! -r "$srcdir/$ac_unique_file"; then
+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
+ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"
+fi
+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
+ac_abs_confdir=`(
+ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"
+ pwd)`
+# When building in place, set srcdir=.
+if test "$ac_abs_confdir" = "$ac_pwd"; then
+ srcdir=.
+fi
+# Remove unnecessary trailing slashes from srcdir.
+# Double slashes in file names in object file debugging info
+# mess up M-x gdb in Emacs.
+case $srcdir in
+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
+esac
+for ac_var in $ac_precious_vars; do
+ eval ac_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_env_${ac_var}_value=\$${ac_var}
+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_cv_env_${ac_var}_value=\$${ac_var}
+done
#
# Report the --help message.
@@ -777,7 +1372,7 @@ 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 tcl 8.6 to adapt to many kinds of systems.
+\`configure' configures tcl 8.7 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -791,20 +1386,17 @@ Configuration:
--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
+ -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]
+ [$ac_default_prefix]
--exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [PREFIX]
+ [PREFIX]
By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
@@ -814,18 +1406,26 @@ 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]
+ --bindir=DIR user executables [EPREFIX/bin]
+ --sbindir=DIR system admin executables [EPREFIX/sbin]
+ --libexecdir=DIR program executables [EPREFIX/libexec]
+ --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]
+ --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
+ --libdir=DIR object code libraries [EPREFIX/lib]
+ --includedir=DIR C header files [PREFIX/include]
+ --oldincludedir=DIR C header files for non-gcc [/usr/include]
+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]
+ --infodir=DIR info documentation [DATAROOTDIR/info]
+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]
+ --mandir=DIR man documentation [DATAROOTDIR/man]
+ --docdir=DIR documentation root [DATAROOTDIR/doc/tcl]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
@@ -834,11 +1434,12 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of tcl 8.6:";;
+ short | recursive ) echo "Configuration of tcl 8.7:";;
esac
cat <<\_ACEOF
Optional Features:
+ --disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
--enable-man-symlinks use symlinks for the manpages (default: off)
@@ -848,7 +1449,6 @@ Optional Features:
use STRING as a suffix to manpage file names
(default: no, tcl if enabled without
specifying STRING)
- --enable-threads build with threads (default: on)
--enable-shared build and link with shared libraries (default: on)
--enable-64bit enable 64bit support (default: off)
--enable-64bit-vis enable 64bit Sparc VIS support (default: off)
@@ -863,12 +1463,15 @@ Optional Features:
--enable-dtrace build with DTrace support (default: off)
--enable-framework package shared libraries in MacOSX frameworks
(default: off)
+ --enable-zipfs build with Zipfs support (default: on)
Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --with-encoding encoding for configuration values (default:
- iso8859-1)
+ --with-encoding encoding for configuration values (default: utf-8)
+ --with-system-libtommath
+ use external libtommath (default: true if available,
+ false otherwise)
--with-tzdata install timezone data (default: autodetect)
Some influential environment variables:
@@ -876,128 +1479,553 @@ Some influential environment variables:
CFLAGS C compiler flags
LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
nonstandard directory <lib dir>
- CPPFLAGS C/C++ preprocessor flags, e.g. -I<include dir> if you have
- headers in a nonstandard directory <include dir>
+ LIBS libraries to pass to the linker, e.g. -l<library>
+ CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if
+ you have headers in a nonstandard directory <include dir>
CPP C preprocessor
Use these variables to override the choices made by `configure' or to help
it to find libraries and programs with nonstandard names/locations.
+Report bugs to the package provider.
_ACEOF
+ac_status=$?
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
+ test -d "$ac_dir" ||
+ { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && 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 "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
case $srcdir in
- .) # No --srcdir option. We are building in place.
+ .) # 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_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
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;;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
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
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+ cd "$ac_dir" || { ac_status=$?; continue; }
+ # Check for configure.gnu first; this name is used for a wrapper for
+ # Metaconfig's "Configure" on case-insensitive file systems.
+ 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
else
- echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi
- cd $ac_popdir
+ printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2
+ fi || ac_status=$?
+ cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
-test -n "$ac_init_help" && exit 0
+test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-tcl configure 8.6
-generated by GNU Autoconf 2.59
+tcl configure 8.7
+generated by GNU Autoconf 2.71
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2021 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
+ exit
fi
-exec 5>config.log
-cat >&5 <<_ACEOF
+
+## ------------------------ ##
+## Autoconf initialization. ##
+## ------------------------ ##
+
+# ac_fn_c_try_compile LINENO
+# --------------------------
+# Try to compile conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest.beam
+ if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_compile
+
+# ac_fn_c_try_link LINENO
+# -----------------------
+# Try to link conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_link ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext && {
+ test "$cross_compiling" = yes ||
+ test -x conftest$ac_exeext
+ }
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
+ # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
+ # interfere with the next link command; also delete a directory that is
+ # left behind by Apple's compiler. We do this before executing the actions.
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_link
+
+# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
+# -------------------------------------------------------
+# Tests whether HEADER exists and can be compiled using the include files in
+# INCLUDES, setting the cache variable VAR accordingly.
+ac_fn_c_check_header_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+printf %s "checking for $2... " >&6; }
+if eval test \${$3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+#include <$2>
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ eval "$3=yes"
+else $as_nop
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_header_compile
+
+# ac_fn_c_try_cpp LINENO
+# ----------------------
+# Try to preprocess conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_cpp ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if { { ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } > conftest.i && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_cpp
+
+# ac_fn_c_check_func LINENO FUNC VAR
+# ----------------------------------
+# Tests whether FUNC exists, setting the cache variable VAR accordingly
+ac_fn_c_check_func ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+printf %s "checking for $2... " >&6; }
+if eval test \${$3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+/* Define $2 to an innocuous variant, in case <limits.h> declares $2.
+ For example, HP-UX 11i <limits.h> declares gettimeofday. */
+#define $2 innocuous_$2
+
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $2 (); below. */
+
+#include <limits.h>
+#undef $2
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char $2 ();
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined __stub_$2 || defined __stub___$2
+choke me
+#endif
+
+int
+main (void)
+{
+return $2 ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"
+then :
+ eval "$3=yes"
+else $as_nop
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_func
+
+# ac_fn_check_decl LINENO SYMBOL VAR INCLUDES EXTRA-OPTIONS FLAG-VAR
+# ------------------------------------------------------------------
+# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR
+# accordingly. Pass EXTRA-OPTIONS to the compiler, using FLAG-VAR.
+ac_fn_check_decl ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ as_decl_name=`echo $2|sed 's/ *(.*//'`
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5
+printf %s "checking whether $as_decl_name is declared... " >&6; }
+if eval test \${$3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`
+ eval ac_save_FLAGS=\$$6
+ as_fn_append $6 " $5"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main (void)
+{
+#ifndef $as_decl_name
+#ifdef __cplusplus
+ (void) $as_decl_use;
+#else
+ (void) $as_decl_name;
+#endif
+#endif
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ eval "$3=yes"
+else $as_nop
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ eval $6=\$ac_save_FLAGS
+
+fi
+eval ac_res=\$$3
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_check_decl
+
+# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
+# -------------------------------------------
+# Tests whether TYPE exists after having included INCLUDES, setting cache
+# variable VAR accordingly.
+ac_fn_c_check_type ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+printf %s "checking for $2... " >&6; }
+if eval test \${$3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ eval "$3=no"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main (void)
+{
+if (sizeof ($2))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main (void)
+{
+if (sizeof (($2)))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+
+else $as_nop
+ eval "$3=yes"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_type
+
+# ac_fn_c_try_run LINENO
+# ----------------------
+# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that
+# executables *can* be run.
+ac_fn_c_try_run ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'
+ { { case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: program exited with status $ac_status" >&5
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=$ac_status
+fi
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_run
+
+# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES
+# ----------------------------------------------------
+# Tries to find if the field MEMBER exists in type AGGR, after including
+# INCLUDES, setting cache variable VAR accordingly.
+ac_fn_c_check_member ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5
+printf %s "checking for $2.$3... " >&6; }
+if eval test \${$4+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$5
+int
+main (void)
+{
+static $2 ac_aggr;
+if (ac_aggr.$3)
+return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ eval "$4=yes"
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$5
+int
+main (void)
+{
+static $2 ac_aggr;
+if (sizeof ac_aggr.$3)
+return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ eval "$4=yes"
+else $as_nop
+ eval "$4=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+eval ac_res=\$$4
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_member
+ac_configure_args_raw=
+for ac_arg
+do
+ case $ac_arg in
+ *\'*)
+ ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ esac
+ as_fn_append ac_configure_args_raw " '$ac_arg'"
+done
+
+case $ac_configure_args_raw in
+ *$as_nl*)
+ ac_safe_unquote= ;;
+ *)
+ ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab.
+ ac_unsafe_a="$ac_unsafe_z#~"
+ ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g"
+ ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;;
+esac
+
+cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by tcl $as_me 8.6, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+It was created by tcl $as_me 8.7, which was
+generated by GNU Autoconf 2.71. Invocation command line was
- $ $0 $@
+ $ $0$ac_configure_args_raw
_ACEOF
+exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
@@ -1016,7 +2044,7 @@ uname -v = `(uname -v) 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`
+/usr/bin/hostinfo = `(/usr/bin/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`
@@ -1027,9 +2055,14 @@ 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
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ printf "%s\n" "PATH: $as_dir"
+ done
+IFS=$as_save_IFS
} >&5
@@ -1051,7 +2084,6 @@ _ACEOF
ac_configure_args=
ac_configure_args0=
ac_configure_args1=
-ac_sep=
ac_must_keep_next=false
for ac_pass in 1 2
do
@@ -1062,13 +2094,13 @@ do
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
- ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ *\'*)
+ ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
- 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
+ 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;
2)
- ac_configure_args1="$ac_configure_args1 '$ac_arg'"
+ as_fn_append ac_configure_args1 " '$ac_arg'"
if test $ac_must_keep_next = true; then
ac_must_keep_next=false # Got value, back to normal.
else
@@ -1084,217 +2116,559 @@ do
-* ) 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=" "
+ as_fn_append ac_configure_args " '$ac_arg'"
;;
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; }
+{ ac_configure_args0=; unset ac_configure_args0;}
+{ ac_configure_args1=; unset 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.
+# WARNING: Use '\'' to represent an apostrophe within the trap.
+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
+ # Sanitize IFS.
+ IFS=" "" $as_nl"
# Save into config.log some information that might help in debugging.
{
echo
- cat <<\_ASBOX
-## ---------------- ##
+ printf "%s\n" "## ---------------- ##
## Cache variables. ##
-## ---------------- ##
-_ASBOX
+## ---------------- ##"
echo
# The following way of writing the cache mishandles newlines in values,
-{
+(
+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
+ *) { eval $ac_var=; unset $ac_var;} ;;
+ esac ;;
+ esac
+ done
(set) 2>&1 |
- case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
- *ac_space=\ *)
+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
sed -n \
- "s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
- ;;
+ "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"
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
- esac;
-}
+ esac |
+ sort
+)
echo
- cat <<\_ASBOX
-## ----------------- ##
+ printf "%s\n" "## ----------------- ##
## Output variables. ##
-## ----------------- ##
-_ASBOX
+## ----------------- ##"
echo
for ac_var in $ac_subst_vars
do
- eval ac_val=$`echo $ac_var`
- echo "$ac_var='"'"'$ac_val'"'"'"
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
- cat <<\_ASBOX
-## ------------- ##
-## Output files. ##
-## ------------- ##
-_ASBOX
+ printf "%s\n" "## ------------------- ##
+## File substitutions. ##
+## ------------------- ##"
echo
for ac_var in $ac_subst_files
do
- eval ac_val=$`echo $ac_var`
- echo "$ac_var='"'"'$ac_val'"'"'"
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
- cat <<\_ASBOX
-## ----------- ##
+ printf "%s\n" "## ----------- ##
## confdefs.h. ##
-## ----------- ##
-_ASBOX
+## ----------- ##"
echo
- sed "/^$/d" confdefs.h | sort
+ cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
- echo "$as_me: caught signal $ac_signal"
- echo "$as_me: exit $exit_status"
+ printf "%s\n" "$as_me: caught signal $ac_signal"
+ printf "%s\n" "$as_me: exit $exit_status"
} >&5
- rm -f core *.core &&
- rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
+ rm -f core *.core core.conftest.* &&
+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
- ' 0
+' 0
for ac_signal in 1 2 13 15; do
- trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
+ trap 'ac_signal='$ac_signal'; as_fn_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.
+rm -f -r conftest* confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_NAME "$PACKAGE_NAME"
-_ACEOF
+printf "%s\n" "/* confdefs.h */" > confdefs.h
+# Predefined preprocessor variables.
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
-_ACEOF
+printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h
+printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_VERSION "$PACKAGE_VERSION"
-_ACEOF
+printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h
+printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_STRING "$PACKAGE_STRING"
-_ACEOF
+printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h
-
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
-_ACEOF
+printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h
# 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
+# Prefer an explicitly selected file to automatically selected ones.
+if test -n "$CONFIG_SITE"; then
+ ac_site_files="$CONFIG_SITE"
+elif test "x$prefix" != xNONE; then
+ ac_site_files="$prefix/share/config.site $prefix/etc/config.site"
+else
+ ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
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;}
+
+for ac_site_file in $ac_site_files
+do
+ case $ac_site_file in #(
+ */*) :
+ ;; #(
+ *) :
+ ac_site_file=./$ac_site_file ;;
+esac
+ if test -f "$ac_site_file" && test -r "$ac_site_file"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
+printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file"
+ . "$ac_site_file" \
+ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "failed to load site script $ac_site_file
+See \`config.log' for more details" "$LINENO" 5; }
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;}
+ # Some versions of bash will fail to source /dev/null (special files
+ # actually), so we avoid doing that. DJGPP emulates it as a regular file.
+ if test /dev/null != "$cache_file" && test -f "$cache_file"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
+printf "%s\n" "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
- [\\/]* | ?:[\\/]* ) . $cache_file;;
- *) . ./$cache_file;;
+ [\\/]* | ?:[\\/]* ) . "$cache_file";;
+ *) . "./$cache_file";;
esac
fi
else
- { echo "$as_me:$LINENO: creating cache $cache_file" >&5
-echo "$as_me: creating cache $cache_file" >&6;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
+printf "%s\n" "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
+# Test code for whether the C compiler supports C89 (global declarations)
+ac_c_conftest_c89_globals='
+/* Does the compiler advertise C89 conformance?
+ Do not test the value of __STDC__, because some compilers set it to 0
+ while being otherwise adequately conformant. */
+#if !defined __STDC__
+# error "Compiler does not advertise C89 conformance"
+#endif
+
+#include <stddef.h>
+#include <stdarg.h>
+struct stat;
+/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */
+struct buf { int x; };
+struct buf * (*rcsopen) (struct buf *, struct stat *, int);
+static char *e (p, i)
+ char **p;
+ int i;
+{
+ return p[i];
+}
+static char *f (char * (*g) (char **, int), char **p, ...)
+{
+ char *s;
+ va_list v;
+ va_start (v,p);
+ s = g (p, va_arg (v,int));
+ va_end (v);
+ return s;
+}
+
+/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
+ function prototypes and stuff, but not \xHH hex character constants.
+ These do not provoke an error unfortunately, instead are silently treated
+ as an "x". The following induces an error, until -std is added to get
+ proper ANSI mode. Curiously \x00 != x always comes out true, for an
+ array size at least. It is necessary to write \x00 == 0 to get something
+ that is true only with -std. */
+int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1];
+
+/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
+ inside strings and character constants. */
+#define FOO(x) '\''x'\''
+int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1];
+
+int test (int i, double x);
+struct s1 {int (*f) (int a);};
+struct s2 {int (*f) (double a);};
+int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int),
+ int, int);'
+
+# Test code for whether the C compiler supports C89 (body of main).
+ac_c_conftest_c89_main='
+ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]);
+'
+
+# Test code for whether the C compiler supports C99 (global declarations)
+ac_c_conftest_c99_globals='
+// Does the compiler advertise C99 conformance?
+#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
+# error "Compiler does not advertise C99 conformance"
+#endif
+
+#include <stdbool.h>
+extern int puts (const char *);
+extern int printf (const char *, ...);
+extern int dprintf (int, const char *, ...);
+extern void *malloc (size_t);
+
+// Check varargs macros. These examples are taken from C99 6.10.3.5.
+// dprintf is used instead of fprintf to avoid needing to declare
+// FILE and stderr.
+#define debug(...) dprintf (2, __VA_ARGS__)
+#define showlist(...) puts (#__VA_ARGS__)
+#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__))
+static void
+test_varargs_macros (void)
+{
+ int x = 1234;
+ int y = 5678;
+ debug ("Flag");
+ debug ("X = %d\n", x);
+ showlist (The first, second, and third items.);
+ report (x>y, "x is %d but y is %d", x, y);
+}
+
+// Check long long types.
+#define BIG64 18446744073709551615ull
+#define BIG32 4294967295ul
+#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0)
+#if !BIG_OK
+ #error "your preprocessor is broken"
+#endif
+#if BIG_OK
+#else
+ #error "your preprocessor is broken"
+#endif
+static long long int bignum = -9223372036854775807LL;
+static unsigned long long int ubignum = BIG64;
+
+struct incomplete_array
+{
+ int datasize;
+ double data[];
+};
+
+struct named_init {
+ int number;
+ const wchar_t *name;
+ double average;
+};
+
+typedef const char *ccp;
+
+static inline int
+test_restrict (ccp restrict text)
+{
+ // See if C++-style comments work.
+ // Iterate through items via the restricted pointer.
+ // Also check for declarations in for loops.
+ for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i)
+ continue;
+ return 0;
+}
+
+// Check varargs and va_copy.
+static bool
+test_varargs (const char *format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ va_list args_copy;
+ va_copy (args_copy, args);
+
+ const char *str = "";
+ int number = 0;
+ float fnumber = 0;
+
+ while (*format)
+ {
+ switch (*format++)
+ {
+ case '\''s'\'': // string
+ str = va_arg (args_copy, const char *);
+ break;
+ case '\''d'\'': // int
+ number = va_arg (args_copy, int);
+ break;
+ case '\''f'\'': // float
+ fnumber = va_arg (args_copy, double);
+ break;
+ default:
+ break;
+ }
+ }
+ va_end (args_copy);
+ va_end (args);
+
+ return *str && number && fnumber;
+}
+'
+
+# Test code for whether the C compiler supports C99 (body of main).
+ac_c_conftest_c99_main='
+ // Check bool.
+ _Bool success = false;
+ success |= (argc != 0);
+
+ // Check restrict.
+ if (test_restrict ("String literal") == 0)
+ success = true;
+ char *restrict newvar = "Another string";
+
+ // Check varargs.
+ success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234);
+ test_varargs_macros ();
+
+ // Check flexible array members.
+ struct incomplete_array *ia =
+ malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10));
+ ia->datasize = 10;
+ for (int i = 0; i < ia->datasize; ++i)
+ ia->data[i] = i * 1.234;
+
+ // Check named initializers.
+ struct named_init ni = {
+ .number = 34,
+ .name = L"Test wide string",
+ .average = 543.34343,
+ };
+
+ ni.number = 58;
+
+ int dynamic_array[ni.number];
+ dynamic_array[0] = argv[0][0];
+ dynamic_array[ni.number - 1] = 543;
+
+ // work around unused variable warnings
+ ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\''
+ || dynamic_array[ni.number - 1] != 543);
+'
+
+# Test code for whether the C compiler supports C11 (global declarations)
+ac_c_conftest_c11_globals='
+// Does the compiler advertise C11 conformance?
+#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L
+# error "Compiler does not advertise C11 conformance"
+#endif
+
+// Check _Alignas.
+char _Alignas (double) aligned_as_double;
+char _Alignas (0) no_special_alignment;
+extern char aligned_as_int;
+char _Alignas (0) _Alignas (int) aligned_as_int;
+
+// Check _Alignof.
+enum
+{
+ int_alignment = _Alignof (int),
+ int_array_alignment = _Alignof (int[100]),
+ char_alignment = _Alignof (char)
+};
+_Static_assert (0 < -_Alignof (int), "_Alignof is signed");
+
+// Check _Noreturn.
+int _Noreturn does_not_return (void) { for (;;) continue; }
+
+// Check _Static_assert.
+struct test_static_assert
+{
+ int x;
+ _Static_assert (sizeof (int) <= sizeof (long int),
+ "_Static_assert does not work in struct");
+ long int y;
+};
+
+// Check UTF-8 literals.
+#define u8 syntax error!
+char const utf8_literal[] = u8"happens to be ASCII" "another string";
+
+// Check duplicate typedefs.
+typedef long *long_ptr;
+typedef long int *long_ptr;
+typedef long_ptr long_ptr;
+
+// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1.
+struct anonymous
+{
+ union {
+ struct { int i; int j; };
+ struct { int k; long int l; } w;
+ };
+ int m;
+} v1;
+'
+
+# Test code for whether the C compiler supports C11 (body of main).
+ac_c_conftest_c11_main='
+ _Static_assert ((offsetof (struct anonymous, i)
+ == offsetof (struct anonymous, w.k)),
+ "Anonymous union alignment botch");
+ v1.i = 2;
+ v1.w.k = 5;
+ ok |= v1.i != 5;
+'
+
+# Test code for whether the C compiler supports C11 (complete).
+ac_c_conftest_c11_program="${ac_c_conftest_c89_globals}
+${ac_c_conftest_c99_globals}
+${ac_c_conftest_c11_globals}
+
+int
+main (int argc, char **argv)
+{
+ int ok = 0;
+ ${ac_c_conftest_c89_main}
+ ${ac_c_conftest_c99_main}
+ ${ac_c_conftest_c11_main}
+ return ok;
+}
+"
+
+# Test code for whether the C compiler supports C99 (complete).
+ac_c_conftest_c99_program="${ac_c_conftest_c89_globals}
+${ac_c_conftest_c99_globals}
+
+int
+main (int argc, char **argv)
+{
+ int ok = 0;
+ ${ac_c_conftest_c89_main}
+ ${ac_c_conftest_c99_main}
+ return ok;
+}
+"
+
+# Test code for whether the C compiler supports C89 (complete).
+ac_c_conftest_c89_program="${ac_c_conftest_c89_globals}
+
+int
+main (int argc, char **argv)
+{
+ int ok = 0;
+ ${ac_c_conftest_c89_main}
+ return ok;
+}
+"
+
+as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H"
+as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H"
+as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H"
+as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H"
+as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H"
+as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H"
+as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H"
+as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H"
+as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H"
+as_fn_append ac_header_c_list " sys/time.h sys_time_h HAVE_SYS_TIME_H"
# 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
+for ac_var in $ac_precious_vars; 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"
+ 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;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+printf "%s\n" "$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;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
+printf "%s\n" "$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=:
+ # differences in whitespace do not lead to failure.
+ ac_old_val_w=`echo x $ac_old_val`
+ ac_new_val_w=`echo x $ac_new_val`
+ if test "$ac_old_val_w" != "$ac_new_val_w"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
+printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ ac_cache_corrupted=:
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
+printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
+ eval $ac_var=\$ac_old_val
+ fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
+printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
+printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;}
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=`printf "%s\n" "$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'" ;;
+ *) as_fn_append 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; }; }
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
+printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;}
+ as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file'
+ and start over" "$LINENO" 5
fi
+## -------------------- ##
+## Main body of script. ##
+## -------------------- ##
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
@@ -1307,35 +2681,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-TCL_VERSION=8.6
+TCL_VERSION=8.7
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL=".13"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a6"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
@@ -1382,62 +2731,63 @@ TCL_SRC_DIR="`cd "$srcdir"/..; pwd`"
#------------------------------------------------------------------------
- echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5
-echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6
- # Check whether --enable-man-symlinks or --disable-man-symlinks was given.
-if test "${enable_man_symlinks+set}" = set; then
- enableval="$enable_man_symlinks"
- test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use symlinks for manpages" >&5
+printf %s "checking whether to use symlinks for manpages... " >&6; }
+ # Check whether --enable-man-symlinks was given.
+if test ${enable_man_symlinks+y}
+then :
+ enableval=$enable_man_symlinks; test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"
+else $as_nop
enableval="no"
-fi;
- echo "$as_me:$LINENO: result: $enableval" >&5
-echo "${ECHO_T}$enableval" >&6
-
- echo "$as_me:$LINENO: checking whether to compress the manpages" >&5
-echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6
- # Check whether --enable-man-compression or --disable-man-compression was given.
-if test "${enable_man_compression+set}" = set; then
- enableval="$enable_man_compression"
- case $enableval in
- yes) { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5
-echo "$as_me: error: missing argument to --enable-man-compression" >&2;}
- { (exit 1); exit 1; }; };;
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
+printf "%s\n" "$enableval" >&6; }
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to compress the manpages" >&5
+printf %s "checking whether to compress the manpages... " >&6; }
+ # Check whether --enable-man-compression was given.
+if test ${enable_man_compression+y}
+then :
+ enableval=$enable_man_compression; case $enableval in
+ yes) as_fn_error $? "missing argument to --enable-man-compression" "$LINENO" 5;;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
esac
-else
+else $as_nop
enableval="no"
-fi;
- echo "$as_me:$LINENO: result: $enableval" >&5
-echo "${ECHO_T}$enableval" >&6
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
+printf "%s\n" "$enableval" >&6; }
if test "$enableval" != "no"; then
- echo "$as_me:$LINENO: checking for compressed file suffix" >&5
-echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for compressed file suffix" >&5
+printf %s "checking for compressed file suffix... " >&6; }
touch TeST
$enableval TeST
Z=`ls TeST* | sed 's/^....//'`
rm -f TeST*
MAN_FLAGS="$MAN_FLAGS --extension $Z"
- echo "$as_me:$LINENO: result: $Z" >&5
-echo "${ECHO_T}$Z" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $Z" >&5
+printf "%s\n" "$Z" >&6; }
fi
- echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5
-echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6
- # Check whether --enable-man-suffix or --disable-man-suffix was given.
-if test "${enable_man_suffix+set}" = set; then
- enableval="$enable_man_suffix"
- case $enableval in
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to add a package name suffix for the manpages" >&5
+printf %s "checking whether to add a package name suffix for the manpages... " >&6; }
+ # Check whether --enable-man-suffix was given.
+if test ${enable_man_suffix+y}
+then :
+ enableval=$enable_man_suffix; case $enableval in
yes) enableval="tcl" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
esac
-else
+else $as_nop
enableval="no"
-fi;
- echo "$as_me:$LINENO: result: $enableval" >&5
-echo "${ECHO_T}$enableval" >&6
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
+printf "%s\n" "$enableval" >&6; }
@@ -1452,6 +2802,15 @@ if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
+
+
+
+
+
+
+
+
+
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
@@ -1460,11 +2819,12 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
set dummy ${ac_tool_prefix}gcc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1472,37 +2832,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}gcc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_CC"; then
ac_ct_CC=$CC
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
@@ -1510,41 +2877,57 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="gcc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
- echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
-echo "${ECHO_T}$ac_ct_CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+printf "%s\n" "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- CC=$ac_ct_CC
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
else
CC="$ac_cv_prog_CC"
fi
if test -z "$CC"; then
- if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
set dummy ${ac_tool_prefix}cc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1552,79 +2935,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}cc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
-else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
-fi
-
-fi
-if test -z "$ac_cv_prog_CC"; then
- ac_ct_CC=$CC
- # Extract the first word of "cc", so it can be a program name with args.
-set dummy cc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if test -n "$ac_ct_CC"; then
- ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_CC="cc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
-done
-
-fi
-fi
-ac_ct_CC=$ac_cv_prog_ac_ct_CC
-if test -n "$ac_ct_CC"; then
- echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
-echo "${ECHO_T}$ac_ct_CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- CC=$ac_ct_CC
-else
- CC="$ac_cv_prog_CC"
-fi
+ fi
fi
if test -z "$CC"; then
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1633,19 +2981,24 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
- if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
ac_prog_rejected=yes
continue
fi
ac_cv_prog_CC="cc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
if test $ac_prog_rejected = yes; then
# We found a bogon in the path, so make sure we never use it.
@@ -1656,32 +3009,34 @@ if test $ac_prog_rejected = yes; then
# However, it has the same basename, so the bogon will be chosen
# first if we set CC to just the basename; use the full file name.
shift
- ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"
+ ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@"
fi
fi
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
- for ac_prog in cl
+ for ac_prog in cl.exe
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1689,41 +3044,48 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
test -n "$CC" && break
done
fi
if test -z "$CC"; then
ac_ct_CC=$CC
- for ac_prog in cl
+ for ac_prog in cl.exe
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
@@ -1731,71 +3093,191 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="$ac_prog"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
- echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
-echo "${ECHO_T}$ac_ct_CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+printf "%s\n" "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
test -n "$ac_ct_CC" && break
done
- CC=$ac_ct_CC
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
fi
fi
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args.
+set dummy ${ac_tool_prefix}clang; ac_word=$2
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ ac_cv_prog_CC="${ac_tool_prefix}clang"
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
+else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+fi
-test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH
-See \`config.log' for more details." >&5
-echo "$as_me: error: no acceptable C compiler found in \$PATH
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+fi
+if test -z "$ac_cv_prog_CC"; then
+ ac_ct_CC=$CC
+ # Extract the first word of "clang", so it can be a program name with args.
+set dummy clang; ac_word=$2
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -n "$ac_ct_CC"; then
+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ ac_cv_prog_ac_ct_CC="clang"
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_CC=$ac_cv_prog_ac_ct_CC
+if test -n "$ac_ct_CC"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+printf "%s\n" "$ac_ct_CC" >&6; }
+else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+fi
+
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+else
+ CC="$ac_cv_prog_CC"
+fi
+
+fi
+
+
+test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "no acceptable C compiler found in \$PATH
+See \`config.log' for more details" "$LINENO" 5; }
# Provide some information about the compiler.
-echo "$as_me:$LINENO:" \
- "checking for C compiler version" >&5
-ac_compiler=`set X $ac_compile; echo $2`
-{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version </dev/null >&5\"") >&5
- (eval $ac_compiler --version </dev/null >&5) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }
-{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v </dev/null >&5\"") >&5
- (eval $ac_compiler -v </dev/null >&5) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }
-{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5
- (eval $ac_compiler -V </dev/null >&5) 2>&5
+printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5
+set X $ac_compile
+ac_compiler=$2
+for ac_option in --version -v -V -qversion -version; do
+ { { ac_try="$ac_compiler $ac_option >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_compiler $ac_option >&5") 2>conftest.err
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }
+ if test -s conftest.err; then
+ sed '10a\
+... rest of stderr output deleted ...
+ 10q' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ fi
+ rm -f conftest.er1 conftest.err
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+done
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
@@ -1803,112 +3285,111 @@ main ()
}
_ACEOF
ac_clean_files_save=$ac_clean_files
-ac_clean_files="$ac_clean_files a.out a.exe b.out"
+ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
-echo "$as_me:$LINENO: checking for C compiler default output file name" >&5
-echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6
-ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
-if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5
- (eval $ac_link_default) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
- # Find the output, starting from the most likely. This scheme is
-# not robust to junk in `.', hence go to wildcards (a.*) only as a last
-# resort.
-
-# Be careful to initialize this variable, since it used to be cached.
-# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile.
-ac_cv_exeext=
-# b.out is created by i960 compilers.
-for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
+printf %s "checking whether the C compiler works... " >&6; }
+ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
+
+# The possible output files:
+ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"
+
+ac_rmfiles=
+for ac_file in $ac_files
+do
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;
+ esac
+done
+rm -f $ac_rmfiles
+
+if { { ac_try="$ac_link_default"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link_default") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+then :
+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
+# in a Makefile. We should not override ac_cv_exeext if it was cached,
+# so that the user can short-circuit this test for compilers unknown to
+# Autoconf.
+for ac_file in $ac_files ''
do
test -f "$ac_file" || continue
case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj )
- ;;
- conftest.$ac_ext )
- # This is the source file.
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )
;;
[ab].out )
# We found the default executable, but exeext='' is most
# certainly right.
break;;
*.* )
- ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
- # FIXME: I believe we export ac_cv_exeext for Libtool,
- # but it would be cool to find out if it's true. Does anybody
- # maintain Libtool? --akim.
- export ac_cv_exeext
+ if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no;
+ then :; else
+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ fi
+ # We set ac_cv_exeext here because the later test for it is not
+ # safe: cross compilers may not add the suffix if given an `-o'
+ # argument, so we may need to know it at that point already.
+ # Even if this section looks crufty: it has the advantage of
+ # actually working.
break;;
* )
break;;
esac
done
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-{ { echo "$as_me:$LINENO: error: C compiler cannot create executables
-See \`config.log' for more details." >&5
-echo "$as_me: error: C compiler cannot create executables
-See \`config.log' for more details." >&2;}
- { (exit 77); exit 77; }; }
-fi
-
+test "$ac_cv_exeext" = no && ac_cv_exeext=
+
+else $as_nop
+ ac_file=''
+fi
+if test -z "$ac_file"
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error 77 "C compiler cannot create executables
+See \`config.log' for more details" "$LINENO" 5; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
+printf %s "checking for C compiler default output file name... " >&6; }
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
+printf "%s\n" "$ac_file" >&6; }
ac_exeext=$ac_cv_exeext
-echo "$as_me:$LINENO: result: $ac_file" >&5
-echo "${ECHO_T}$ac_file" >&6
-# Check the compiler produces executables we can run. If not, either
-# the compiler is broken, or we cross compile.
-echo "$as_me:$LINENO: checking whether the C compiler works" >&5
-echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6
-# FIXME: These cross compiler hacks should be removed for Autoconf 3.0
-# If not cross compiling, check that we can run a simple program.
-if test "$cross_compiling" != yes; then
- if { ac_try='./$ac_file'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- cross_compiling=no
- else
- if test "$cross_compiling" = maybe; then
- cross_compiling=yes
- else
- { { echo "$as_me:$LINENO: error: cannot run C compiled programs.
-If you meant to cross compile, use \`--host'.
-See \`config.log' for more details." >&5
-echo "$as_me: error: cannot run C compiled programs.
-If you meant to cross compile, use \`--host'.
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
- fi
- fi
-fi
-echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
-
-rm -f a.out a.exe conftest$ac_cv_exeext b.out
+rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out
ac_clean_files=$ac_clean_files_save
-# Check the compiler produces executables we can run. If not, either
-# the compiler is broken, or we cross compile.
-echo "$as_me:$LINENO: checking whether we are cross compiling" >&5
-echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6
-echo "$as_me:$LINENO: result: $cross_compiling" >&5
-echo "${ECHO_T}$cross_compiling" >&6
-
-echo "$as_me:$LINENO: checking for suffix of executables" >&5
-echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
+printf %s "checking for suffix of executables... " >&6; }
+if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+then :
# If both `conftest.exe' and `conftest' are `present' (well, observable)
# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
# work properly (i.e., refer to `conftest.exe'), while it won't with
@@ -1916,42 +3397,95 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
for ac_file in conftest.exe conftest conftest.*; do
test -f "$ac_file" || continue
case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;;
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
*.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
- export ac_cv_exeext
break;;
* ) break;;
esac
done
-else
- { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
-See \`config.log' for more details." >&5
-echo "$as_me: error: cannot compute suffix of executables: cannot compile and link
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+else $as_nop
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details" "$LINENO" 5; }
fi
-
-rm -f conftest$ac_cv_exeext
-echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5
-echo "${ECHO_T}$ac_cv_exeext" >&6
+rm -f conftest conftest$ac_cv_exeext
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
+printf "%s\n" "$ac_cv_exeext" >&6; }
rm -f conftest.$ac_ext
EXEEXT=$ac_cv_exeext
ac_exeext=$EXEEXT
-echo "$as_me:$LINENO: checking for suffix of object files" >&5
-echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6
-if test "${ac_cv_objext+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <stdio.h>
+int
+main (void)
+{
+FILE *f = fopen ("conftest.out", "w");
+ return ferror (f) || fclose (f) != 0;
+
+ ;
+ return 0;
+}
_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ac_clean_files="$ac_clean_files conftest.out"
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
+printf %s "checking whether we are cross compiling... " >&6; }
+if test "$cross_compiling" != yes; then
+ { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ if { ac_try='./conftest$ac_cv_exeext'
+ { { case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }; then
+ cross_compiling=no
+ else
+ if test "$cross_compiling" = maybe; then
+ cross_compiling=yes
+ else
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error 77 "cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details" "$LINENO" 5; }
+ fi
+ fi
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
+printf "%s\n" "$cross_compiling" >&6; }
+
+rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
+ac_clean_files=$ac_clean_files_save
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
+printf %s "checking for suffix of object files... " >&6; }
+if test ${ac_cv_objext+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
@@ -1959,49 +3493,52 @@ main ()
}
_ACEOF
rm -f conftest.o conftest.obj
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
- for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do
+if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+then :
+ for ac_file in conftest.o conftest.obj conftest.*; do
+ test -f "$ac_file" || continue;
case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;;
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;
*) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
break;;
esac
done
-else
- echo "$as_me: failed program was:" >&5
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
-{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile
-See \`config.log' for more details." >&5
-echo "$as_me: error: cannot compute suffix of object files: cannot compile
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compute suffix of object files: cannot compile
+See \`config.log' for more details" "$LINENO" 5; }
fi
-
rm -f conftest.$ac_cv_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_objext" >&5
-echo "${ECHO_T}$ac_cv_objext" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
+printf "%s\n" "$ac_cv_objext" >&6; }
OBJEXT=$ac_cv_objext
ac_objext=$OBJEXT
-echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
-echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6
-if test "${ac_cv_c_compiler_gnu+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5
+printf %s "checking whether the compiler supports GNU C... " >&6; }
+if test ${ac_cv_c_compiler_gnu+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
#ifndef __GNUC__
choke me
@@ -2011,99 +3548,95 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_compiler_gnu=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_compiler_gnu=no
+else $as_nop
+ ac_compiler_gnu=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu
fi
-echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
-echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6
-GCC=`test $ac_compiler_gnu = yes && echo yes`
-ac_test_CFLAGS=${CFLAGS+set}
-ac_save_CFLAGS=$CFLAGS
-CFLAGS="-g"
-echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
-echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6
-if test "${ac_cv_prog_cc_g+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
+printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; }
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+if test $ac_compiler_gnu = yes; then
+ GCC=yes
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ GCC=
+fi
+ac_test_CFLAGS=${CFLAGS+y}
+ac_save_CFLAGS=$CFLAGS
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
+printf %s "checking whether $CC accepts -g... " >&6; }
+if test ${ac_cv_prog_cc_g+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_save_c_werror_flag=$ac_c_werror_flag
+ ac_c_werror_flag=yes
+ ac_cv_prog_cc_g=no
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_prog_cc_g=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+else $as_nop
+ CFLAGS=""
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main (void)
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+
+else $as_nop
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main (void)
+{
-ac_cv_prog_cc_g=no
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_g=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
-echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
-if test "$ac_test_CFLAGS" = set; then
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
+printf "%s\n" "$ac_cv_prog_cc_g" >&6; }
+if test $ac_test_CFLAGS; then
CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
if test "$GCC" = yes; then
@@ -2118,264 +3651,146 @@ else
CFLAGS=
fi
fi
-echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5
-echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6
-if test "${ac_cv_prog_cc_stdc+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_prog_cc_stdc=no
+ac_prog_cc_stdc=no
+if test x$ac_prog_cc_stdc = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5
+printf %s "checking for $CC option to enable C11 features... " >&6; }
+if test ${ac_cv_prog_cc_c11+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_prog_cc_c11=no
ac_save_CC=$CC
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-#include <stdarg.h>
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */
-struct buf { int x; };
-FILE * (*rcsopen) (struct buf *, struct stat *, int);
-static char *e (p, i)
- char **p;
- int i;
-{
- return p[i];
-}
-static char *f (char * (*g) (char **, int), char **p, ...)
-{
- char *s;
- va_list v;
- va_start (v,p);
- s = g (p, va_arg (v,int));
- va_end (v);
- return s;
-}
-
-/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
- function prototypes and stuff, but not '\xHH' hex character constants.
- These don't provoke an error unfortunately, instead are silently treated
- as 'x'. The following induces an error, until -std1 is added to get
- proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an
- array size at least. It's necessary to write '\x00'==0 to get something
- that's true only with -std1. */
-int osf4_cc_array ['\x00' == 0 ? 1 : -1];
-
-int test (int i, double x);
-struct s1 {int (*f) (int a);};
-struct s2 {int (*f) (double a);};
-int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
-int argc;
-char **argv;
-int
-main ()
-{
-return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
- ;
- return 0;
-}
+$ac_c_conftest_c11_program
_ACEOF
-# Don't try gcc -ansi; that turns off useful extensions and
-# breaks some systems' header files.
-# AIX -qlanglvl=ansi
-# Ultrix and OSF/1 -std1
-# HP-UX 10.20 and later -Ae
-# HP-UX older versions -Aa -D_HPUX_SOURCE
-# SVR4 -Xc -D__EXTENSIONS__
-for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+for ac_arg in '' -std=gnu11
do
CC="$ac_save_CC $ac_arg"
- rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_prog_cc_stdc=$ac_arg
-break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+ if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_c11=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext
+rm -f core conftest.err conftest.$ac_objext conftest.beam
+ test "x$ac_cv_prog_cc_c11" != "xno" && break
done
-rm -f conftest.$ac_ext conftest.$ac_objext
+rm -f conftest.$ac_ext
CC=$ac_save_CC
-
fi
-case "x$ac_cv_prog_cc_stdc" in
- x|xno)
- echo "$as_me:$LINENO: result: none needed" >&5
-echo "${ECHO_T}none needed" >&6 ;;
- *)
- echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5
-echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6
- CC="$CC $ac_cv_prog_cc_stdc" ;;
-esac
-
-# Some people use a C++ compiler to compile C. Since we use `exit',
-# in C++ we need to declare it. In case someone uses the same compiler
-# for both compiling C and C++ we need to have the C++ compiler decide
-# the declaration of exit, since it's the most demanding environment.
-cat >conftest.$ac_ext <<_ACEOF
-#ifndef __cplusplus
- choke me
-#endif
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- for ac_declaration in \
- '' \
- 'extern "C" void std::exit (int) throw (); using std::exit;' \
- 'extern "C" void std::exit (int); using std::exit;' \
- 'extern "C" void exit (int) throw ();' \
- 'extern "C" void exit (int);' \
- 'void exit (int);'
-do
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+if test "x$ac_cv_prog_cc_c11" = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+printf "%s\n" "unsupported" >&6; }
+else $as_nop
+ if test "x$ac_cv_prog_cc_c11" = x
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+printf "%s\n" "none needed" >&6; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5
+printf "%s\n" "$ac_cv_prog_cc_c11" >&6; }
+ CC="$CC $ac_cv_prog_cc_c11"
+fi
+ ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11
+ ac_prog_cc_stdc=c11
+fi
+fi
+if test x$ac_prog_cc_stdc = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5
+printf %s "checking for $CC option to enable C99 features... " >&6; }
+if test ${ac_cv_prog_cc_c99+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_prog_cc_c99=no
+ac_save_CC=$CC
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-$ac_declaration
-#include <stdlib.h>
-int
-main ()
-{
-exit (42);
- ;
- return 0;
-}
+$ac_c_conftest_c99_program
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-continue
+for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99=
+do
+ CC="$ac_save_CC $ac_arg"
+ if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_c99=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+rm -f core conftest.err conftest.$ac_objext conftest.beam
+ test "x$ac_cv_prog_cc_c99" != "xno" && break
+done
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
+fi
+
+if test "x$ac_cv_prog_cc_c99" = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+printf "%s\n" "unsupported" >&6; }
+else $as_nop
+ if test "x$ac_cv_prog_cc_c99" = x
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+printf "%s\n" "none needed" >&6; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5
+printf "%s\n" "$ac_cv_prog_cc_c99" >&6; }
+ CC="$CC $ac_cv_prog_cc_c99"
+fi
+ ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99
+ ac_prog_cc_stdc=c99
+fi
+fi
+if test x$ac_prog_cc_stdc = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5
+printf %s "checking for $CC option to enable C89 features... " >&6; }
+if test ${ac_cv_prog_cc_c89+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_prog_cc_c89=no
+ac_save_CC=$CC
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-$ac_declaration
-int
-main ()
-{
-exit (42);
- ;
- return 0;
-}
+$ac_c_conftest_c89_program
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+do
+ CC="$ac_save_CC $ac_arg"
+ if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_c89=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam
+ test "x$ac_cv_prog_cc_c89" != "xno" && break
done
-rm -f conftest*
-if test -n "$ac_declaration"; then
- echo '#ifdef __cplusplus' >>confdefs.h
- echo $ac_declaration >>confdefs.h
- echo '#endif' >>confdefs.h
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
fi
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+if test "x$ac_cv_prog_cc_c89" = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+printf "%s\n" "unsupported" >&6; }
+else $as_nop
+ if test "x$ac_cv_prog_cc_c89" = x
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+printf "%s\n" "none needed" >&6; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
+printf "%s\n" "$ac_cv_prog_cc_c89" >&6; }
+ CC="$CC $ac_cv_prog_cc_c89"
+fi
+ ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89
+ ac_prog_cc_stdc=c89
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
@@ -2383,61 +3798,34 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $
ac_compiler_gnu=$ac_cv_c_compiler_gnu
-echo "$as_me:$LINENO: checking for inline" >&5
-echo $ECHO_N "checking for inline... $ECHO_C" >&6
-if test "${ac_cv_c_inline+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
+printf %s "checking for inline... " >&6; }
+if test ${ac_cv_c_inline+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_cv_c_inline=no
for ac_kw in inline __inline__ __inline; do
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef __cplusplus
typedef int foo_t;
-static $ac_kw foo_t static_foo () {return 0; }
-$ac_kw foo_t foo () {return 0; }
+static $ac_kw foo_t static_foo (void) {return 0; }
+$ac_kw foo_t foo (void) {return 0; }
#endif
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_c_inline=$ac_kw; break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_c_inline=$ac_kw
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ test "$ac_cv_c_inline" != no && break
done
fi
-echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5
-echo "${ECHO_T}$ac_cv_c_inline" >&6
-
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
+printf "%s\n" "$ac_cv_c_inline" >&6; }
case $ac_cv_c_inline in
inline | yes) ;;
@@ -2455,127 +3843,107 @@ _ACEOF
esac
+
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
-# - stdlib.h doesn't define strtol, strtoul, or
-# strtod in some versions of SunOS
+# - stdlib.h doesn't define strtol or strtoul in some versions
+# of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------
+ac_header= ac_cache=
+for ac_item in $ac_header_c_list
+do
+ if test $ac_cache; then
+ ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default"
+ if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then
+ printf "%s\n" "#define $ac_item 1" >> confdefs.h
+ fi
+ ac_header= ac_cache=
+ elif test $ac_header; then
+ ac_cache=$ac_item
+ else
+ ac_header=$ac_item
+ fi
+done
+
+
+
+
+
+
+
+
+if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes
+then :
+
+printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h
+
+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
-echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5
-echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
+printf %s "checking how to run the C preprocessor... " >&6; }
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
fi
if test -z "$CPP"; then
- if test "${ac_cv_prog_CPP+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- # Double quotes because CPP needs to be expanded
- for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"
+ if test ${ac_cv_prog_CPP+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ # Double quotes because $CC needs to be expanded
+ for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp
do
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
# Use a header file that comes with gcc, so configuring glibc
# with a fresh cross-compiler works.
- # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- # <limits.h> exists even on freestanding compilers.
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp. "Syntax error" is here to catch this case.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+#include <limits.h>
Syntax error
_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+if ac_fn_c_try_cpp "$LINENO"
+then :
+else $as_nop
# Broken: fails on valid input.
continue
fi
-rm -f conftest.err conftest.$ac_ext
+rm -f conftest.err conftest.i conftest.$ac_ext
- # OK, works on sane cases. Now check whether non-existent headers
+ # OK, works on sane cases. Now check whether nonexistent headers
# can be detected and how.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <ac_nonexistent.h>
_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
+if ac_fn_c_try_cpp "$LINENO"
+then :
# Broken: success on invalid input.
continue
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+else $as_nop
# Passes both tests.
ac_preproc_ok=:
break
fi
-rm -f conftest.err conftest.$ac_ext
+rm -f conftest.err conftest.i conftest.$ac_ext
done
# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
-rm -f conftest.err conftest.$ac_ext
-if $ac_preproc_ok; then
+rm -f conftest.i conftest.err conftest.$ac_ext
+if $ac_preproc_ok
+then :
break
fi
@@ -2587,109 +3955,57 @@ fi
else
ac_cv_prog_CPP=$CPP
fi
-echo "$as_me:$LINENO: result: $CPP" >&5
-echo "${ECHO_T}$CPP" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
+printf "%s\n" "$CPP" >&6; }
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
# Use a header file that comes with gcc, so configuring glibc
# with a fresh cross-compiler works.
- # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- # <limits.h> exists even on freestanding compilers.
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp. "Syntax error" is here to catch this case.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+#include <limits.h>
Syntax error
_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+if ac_fn_c_try_cpp "$LINENO"
+then :
+else $as_nop
# Broken: fails on valid input.
continue
fi
-rm -f conftest.err conftest.$ac_ext
+rm -f conftest.err conftest.i conftest.$ac_ext
- # OK, works on sane cases. Now check whether non-existent headers
+ # OK, works on sane cases. Now check whether nonexistent headers
# can be detected and how.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <ac_nonexistent.h>
_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
+if ac_fn_c_try_cpp "$LINENO"
+then :
# Broken: success on invalid input.
continue
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+else $as_nop
# Passes both tests.
ac_preproc_ok=:
break
fi
-rm -f conftest.err conftest.$ac_ext
+rm -f conftest.err conftest.i conftest.$ac_ext
done
# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
-rm -f conftest.err conftest.$ac_ext
-if $ac_preproc_ok; then
- :
-else
- { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check
-See \`config.log' for more details." >&5
-echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+rm -f conftest.i conftest.err conftest.$ac_ext
+if $ac_preproc_ok
+then :
+
+else $as_nop
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "C preprocessor \"$CPP\" fails sanity check
+See \`config.log' for more details" "$LINENO" 5; }
fi
ac_ext=c
@@ -2699,277 +4015,162 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $
ac_compiler_gnu=$ac_cv_c_compiler_gnu
-echo "$as_me:$LINENO: checking for egrep" >&5
-echo $ECHO_N "checking for egrep... $ECHO_C" >&6
-if test "${ac_cv_prog_egrep+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if echo a | (grep -E '(a|b)') >/dev/null 2>&1
- then ac_cv_prog_egrep='grep -E'
- else ac_cv_prog_egrep='egrep'
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
+printf %s "checking for grep that handles long lines and -e... " >&6; }
+if test ${ac_cv_path_GREP+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -z "$GREP"; then
+ ac_path_GREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_prog in grep ggrep
+ do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_GREP="$as_dir$ac_prog$ac_exec_ext"
+ as_fn_executable_p "$ac_path_GREP" || continue
+# Check for GNU ac_path_GREP and select it if it is found.
+ # Check for GNU $ac_path_GREP
+case `"$ac_path_GREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;
+*)
+ ac_count=0
+ printf %s 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ printf "%s\n" 'GREP' >> "conftest.nl"
+ "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_GREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_GREP="$ac_path_GREP"
+ ac_path_GREP_max=$ac_count
fi
-fi
-echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5
-echo "${ECHO_T}$ac_cv_prog_egrep" >&6
- EGREP=$ac_cv_prog_egrep
-
-
-echo "$as_me:$LINENO: checking for ANSI C header files" >&5
-echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6
-if test "${ac_cv_header_stdc+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <stdlib.h>
-#include <stdarg.h>
-#include <string.h>
-#include <float.h>
-
-int
-main ()
-{
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_header_stdc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_header_stdc=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-if test $ac_cv_header_stdc = yes; then
- # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <string.h>
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "memchr" >/dev/null 2>&1; then
- :
-else
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-fi
-
-if test $ac_cv_header_stdc = yes; then
- # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <stdlib.h>
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "free" >/dev/null 2>&1; then
- :
-else
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-fi
-
-if test $ac_cv_header_stdc = yes; then
- # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
- if test "$cross_compiling" = yes; then
- :
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <ctype.h>
-#include <stdlib.h>
-#if ((' ' & 0x0FF) == 0x020)
-# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
-# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
-#else
-# define ISLOWER(c) \
- (('a' <= (c) && (c) <= 'i') \
- || ('j' <= (c) && (c) <= 'r') \
- || ('s' <= (c) && (c) <= 'z'))
-# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
-#endif
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
-#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
-int
-main ()
-{
- int i;
- for (i = 0; i < 256; i++)
- if (XOR (islower (i), ISLOWER (i))
- || toupper (i) != TOUPPER (i))
- exit(2);
- exit (0);
-}
-_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- :
+ $ac_path_GREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_GREP"; then
+ as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-ac_cv_header_stdc=no
-fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+ ac_cv_path_GREP=$GREP
fi
-fi
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
-echo "${ECHO_T}$ac_cv_header_stdc" >&6
-if test $ac_cv_header_stdc = yes; then
-
-cat >>confdefs.h <<\_ACEOF
-#define STDC_HEADERS 1
-_ACEOF
fi
-
-# On IRIX 5.3, sys/types and inttypes.h are conflicting.
-
-
-
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
+printf "%s\n" "$ac_cv_path_GREP" >&6; }
+ GREP="$ac_cv_path_GREP"
-
-
-
-
-for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
- inttypes.h stdint.h unistd.h
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
+printf %s "checking for egrep... " >&6; }
+if test ${ac_cv_path_EGREP+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if echo a | $GREP -E '(a|b)' >/dev/null 2>&1
+ then ac_cv_path_EGREP="$GREP -E"
+ else
+ if test -z "$EGREP"; then
+ ac_path_EGREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_prog in egrep
+ do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext"
+ as_fn_executable_p "$ac_path_EGREP" || continue
+# Check for GNU ac_path_EGREP and select it if it is found.
+ # Check for GNU $ac_path_EGREP
+case `"$ac_path_EGREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;
+*)
+ ac_count=0
+ printf %s 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ printf "%s\n" 'EGREP' >> "conftest.nl"
+ "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_EGREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_EGREP="$ac_path_EGREP"
+ ac_path_EGREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_Header=yes"
+ $ac_path_EGREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_EGREP"; then
+ as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_Header=no"
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+ ac_cv_path_EGREP=$EGREP
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+ fi
fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
+printf "%s\n" "$ac_cv_path_EGREP" >&6; }
+ EGREP="$ac_cv_path_EGREP"
-done
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking dirent.h" >&5
+printf %s "checking dirent.h... " >&6; }
+if test ${tcl_cv_dirent_h+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- echo "$as_me:$LINENO: checking dirent.h" >&5
-echo $ECHO_N "checking dirent.h... $ECHO_C" >&6
-if test "${tcl_cv_dirent_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
-main ()
+main (void)
{
#ifndef _POSIX_SOURCE
@@ -2994,724 +4195,100 @@ closedir(d);
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_dirent_h=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_dirent_h=no
+else $as_nop
+ tcl_cv_dirent_h=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_dirent_h" >&5
-echo "${ECHO_T}$tcl_cv_dirent_h" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_dirent_h" >&5
+printf "%s\n" "$tcl_cv_dirent_h" >&6; }
if test $tcl_cv_dirent_h = no; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_DIRENT_H 1
-_ACEOF
+printf "%s\n" "#define NO_DIRENT_H 1" >>confdefs.h
fi
- if test "${ac_cv_header_float_h+set}" = set; then
- echo "$as_me:$LINENO: checking for float.h" >&5
-echo $ECHO_N "checking for float.h... $ECHO_C" >&6
-if test "${ac_cv_header_float_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5
-echo "${ECHO_T}$ac_cv_header_float_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking float.h usability" >&5
-echo $ECHO_N "checking float.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <float.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking float.h presence" >&5
-echo $ECHO_N "checking float.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <float.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: float.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: float.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: float.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: float.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: float.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for float.h" >&5
-echo $ECHO_N "checking for float.h... $ECHO_C" >&6
-if test "${ac_cv_header_float_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_float_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5
-echo "${ECHO_T}$ac_cv_header_float_h" >&6
-
-fi
-if test $ac_cv_header_float_h = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_FLOAT_H 1
-_ACEOF
-
-fi
-
-
- if test "${ac_cv_header_values_h+set}" = set; then
- echo "$as_me:$LINENO: checking for values.h" >&5
-echo $ECHO_N "checking for values.h... $ECHO_C" >&6
-if test "${ac_cv_header_values_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5
-echo "${ECHO_T}$ac_cv_header_values_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking values.h usability" >&5
-echo $ECHO_N "checking values.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <values.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking values.h presence" >&5
-echo $ECHO_N "checking values.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <values.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: values.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: values.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: values.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: values.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: values.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for values.h" >&5
-echo $ECHO_N "checking for values.h... $ECHO_C" >&6
-if test "${ac_cv_header_values_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_values_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5
-echo "${ECHO_T}$ac_cv_header_values_h" >&6
-
-fi
-if test $ac_cv_header_values_h = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_VALUES_H 1
-_ACEOF
-
-fi
-
-
- if test "${ac_cv_header_stdlib_h+set}" = set; then
- echo "$as_me:$LINENO: checking for stdlib.h" >&5
-echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6
-if test "${ac_cv_header_stdlib_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5
-echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking stdlib.h usability" >&5
-echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <stdlib.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking stdlib.h presence" >&5
-echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <stdlib.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for stdlib.h" >&5
-echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6
-if test "${ac_cv_header_stdlib_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_stdlib_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5
-echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6
-
-fi
-if test $ac_cv_header_stdlib_h = yes; then
+ ac_fn_c_check_header_compile "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default"
+if test "x$ac_cv_header_stdlib_h" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "strtol" >/dev/null 2>&1; then
- :
-else
- tcl_ok=0
-fi
-rm -f conftest*
+ $EGREP "strtol" >/dev/null 2>&1
+then :
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <stdlib.h>
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "strtoul" >/dev/null 2>&1; then
- :
-else
+else $as_nop
tcl_ok=0
fi
-rm -f conftest*
+rm -rf conftest*
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "strtod" >/dev/null 2>&1; then
- :
-else
+ $EGREP "strtoul" >/dev/null 2>&1
+then :
+
+else $as_nop
tcl_ok=0
fi
-rm -f conftest*
+rm -rf conftest*
if test $tcl_ok = 0; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_STDLIB_H 1
-_ACEOF
+printf "%s\n" "#define NO_STDLIB_H 1" >>confdefs.h
fi
- if test "${ac_cv_header_string_h+set}" = set; then
- echo "$as_me:$LINENO: checking for string.h" >&5
-echo $ECHO_N "checking for string.h... $ECHO_C" >&6
-if test "${ac_cv_header_string_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5
-echo "${ECHO_T}$ac_cv_header_string_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking string.h usability" >&5
-echo $ECHO_N "checking string.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <string.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking string.h presence" >&5
-echo $ECHO_N "checking string.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <string.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: string.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: string.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: string.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: string.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: string.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for string.h" >&5
-echo $ECHO_N "checking for string.h... $ECHO_C" >&6
-if test "${ac_cv_header_string_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_string_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5
-echo "${ECHO_T}$ac_cv_header_string_h" >&6
-
-fi
-if test $ac_cv_header_string_h = yes; then
+ ac_fn_c_check_header_compile "$LINENO" "string.h" "ac_cv_header_string_h" "$ac_includes_default"
+if test "x$ac_cv_header_string_h" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <string.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "strstr" >/dev/null 2>&1; then
- :
-else
+ $EGREP "strstr" >/dev/null 2>&1
+then :
+
+else $as_nop
tcl_ok=0
fi
-rm -f conftest*
+rm -rf conftest*
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <string.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "strerror" >/dev/null 2>&1; then
- :
-else
+ $EGREP "strerror" >/dev/null 2>&1
+then :
+
+else $as_nop
tcl_ok=0
fi
-rm -f conftest*
+rm -rf conftest*
# See also memmove check below for a place where NO_STRING_H can be
@@ -3719,459 +4296,38 @@ rm -f conftest*
if test $tcl_ok = 0; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_STRING_H 1
-_ACEOF
+printf "%s\n" "#define NO_STRING_H 1" >>confdefs.h
fi
- if test "${ac_cv_header_sys_wait_h+set}" = set; then
- echo "$as_me:$LINENO: checking for sys/wait.h" >&5
-echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6
-if test "${ac_cv_header_sys_wait_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5
-echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking sys/wait.h usability" >&5
-echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <sys/wait.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking sys/wait.h presence" >&5
-echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <sys/wait.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: sys/wait.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: sys/wait.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for sys/wait.h" >&5
-echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6
-if test "${ac_cv_header_sys_wait_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_sys_wait_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5
-echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6
-
-fi
-if test $ac_cv_header_sys_wait_h = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_SYS_WAIT_H 1
-_ACEOF
-
-fi
-
-
- if test "${ac_cv_header_dlfcn_h+set}" = set; then
- echo "$as_me:$LINENO: checking for dlfcn.h" >&5
-echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6
-if test "${ac_cv_header_dlfcn_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5
-echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking dlfcn.h usability" >&5
-echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <dlfcn.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ ac_fn_c_check_header_compile "$LINENO" "sys/wait.h" "ac_cv_header_sys_wait_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_wait_h" = xyes
+then :
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
+else $as_nop
-# Is the header present?
-echo "$as_me:$LINENO: checking dlfcn.h presence" >&5
-echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <dlfcn.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+printf "%s\n" "#define NO_SYS_WAIT_H 1" >>confdefs.h
- ac_header_preproc=no
fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: dlfcn.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: dlfcn.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for dlfcn.h" >&5
-echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6
-if test "${ac_cv_header_dlfcn_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_dlfcn_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5
-echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6
+ ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default"
+if test "x$ac_cv_header_dlfcn_h" = xyes
+then :
-fi
-if test $ac_cv_header_dlfcn_h = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define NO_DLFCN_H 1
-_ACEOF
+printf "%s\n" "#define NO_DLFCN_H 1" >>confdefs.h
fi
-
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
+ ac_fn_c_check_header_compile "$LINENO" "sys/param.h" "ac_cv_header_sys_param_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_param_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_PARAM_H 1" >>confdefs.h
-for ac_header in sys/param.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-
-done
@@ -4187,655 +4343,148 @@ done
#------------------------------------------------------------------------
if test -z "$no_pipe" && test -n "$GCC"; then
- echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5
-echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6
-if test "${tcl_cv_cc_pipe+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -pipe" >&5
+printf %s "checking if the compiler understands -pipe... " >&6; }
+if test ${tcl_cv_cc_pipe+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_cc_pipe=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_pipe=no
+else $as_nop
+ tcl_cv_cc_pipe=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_pipe" >&5
-echo "${ECHO_T}$tcl_cv_cc_pipe" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5
+printf "%s\n" "$tcl_cv_cc_pipe" >&6; }
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
#------------------------------------------------------------------------
-# Threads support
+# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
- # Check whether --enable-threads or --disable-threads was given.
-if test "${enable_threads+set}" = set; then
- enableval="$enable_threads"
- tcl_ok=$enableval
-else
- tcl_ok=yes
-fi;
-
- if test "${TCL_THREADS}" = 1; then
- tcl_threaded_core=1;
- fi
-
- if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then
- TCL_THREADS=1
- # USE_THREAD_ALLOC tells us to try the special thread-based
- # allocator that significantly reduces lock contention
-
-cat >>confdefs.h <<\_ACEOF
-#define USE_THREAD_ALLOC 1
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define _REENTRANT 1
-_ACEOF
-
- if test "`uname -s`" = "SunOS" ; then
-
-cat >>confdefs.h <<\_ACEOF
-#define _POSIX_PTHREAD_SEMANTICS 1
-_ACEOF
- fi
-
-cat >>confdefs.h <<\_ACEOF
-#define _THREAD_SAFE 1
-_ACEOF
-
- echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthread" >&5
-echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6
-if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_check_lib_save_LIBS=$LIBS
-LIBS="-lpthread $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char pthread_mutex_init ();
-int
-main ()
-{
-pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_pthread_pthread_mutex_init=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_pthread_pthread_mutex_init=no
+# Check whether --with-encoding was given.
+if test ${with_encoding+y}
+then :
+ withval=$with_encoding; with_tcencoding=${withval}
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS
-fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
-echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6
-if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then
- tcl_ok=yes
-else
- tcl_ok=no
-fi
-
- if test "$tcl_ok" = "no"; then
- # Check a little harder for __pthread_mutex_init in the same
- # library, as some systems hide it there until pthread.h is
- # defined. We could alternatively do an AC_TRY_COMPILE with
- # pthread.h, but that will work with libpthread really doesn't
- # exist, like AIX 4.2. [Bug: 4359]
- echo "$as_me:$LINENO: checking for __pthread_mutex_init in -lpthread" >&5
-echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6
-if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_check_lib_save_LIBS=$LIBS
-LIBS="-lpthread $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char __pthread_mutex_init ();
-int
-main ()
-{
-__pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_pthread___pthread_mutex_init=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-ac_cv_lib_pthread___pthread_mutex_init=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS
-fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
-echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6
-if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then
- tcl_ok=yes
-else
- tcl_ok=no
-fi
+ if test x"${with_tcencoding}" != x ; then
- fi
+printf "%s\n" "#define TCL_CFGVAL_ENCODING \"${with_tcencoding}\"" >>confdefs.h
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -lpthread"
- else
- echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthreads" >&5
-echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6
-if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_check_lib_save_LIBS=$LIBS
-LIBS="-lpthreads $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
+ else
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char pthread_mutex_init ();
-int
-main ()
-{
-pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_pthreads_pthread_mutex_init=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+printf "%s\n" "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h
-ac_cv_lib_pthreads_pthread_mutex_init=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS
-fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
-echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6
-if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then
- tcl_ok=yes
-else
- tcl_ok=no
-fi
+ fi
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -lpthreads"
- else
- echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc" >&5
-echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6
-if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_check_lib_save_LIBS=$LIBS
-LIBS="-lc $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char pthread_mutex_init ();
-int
-main ()
-{
-pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_c_pthread_mutex_init=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_c_pthread_mutex_init=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS
-fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5
-echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6
-if test $ac_cv_lib_c_pthread_mutex_init = yes; then
- tcl_ok=yes
-else
- tcl_ok=no
-fi
+#--------------------------------------------------------------------
+# Look for libraries that we will need when compiling the Tcl shell
+#--------------------------------------------------------------------
- if test "$tcl_ok" = "no"; then
- echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5
-echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6
-if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_check_lib_save_LIBS=$LIBS
-LIBS="-lc_r $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC options needed to detect all undeclared functions" >&5
+printf %s "checking for $CC options needed to detect all undeclared functions... " >&6; }
+if test ${ac_cv_c_undeclared_builtin_options+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_save_CFLAGS=$CFLAGS
+ ac_cv_c_undeclared_builtin_options='cannot detect'
+ for ac_arg in '' -fno-builtin; do
+ CFLAGS="$ac_save_CFLAGS $ac_arg"
+ # This test program should *not* compile successfully.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char pthread_mutex_init ();
int
-main ()
+main (void)
{
-pthread_mutex_init ();
+(void) strchr;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_c_r_pthread_mutex_init=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_c_r_pthread_mutex_init=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS
-fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
-echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6
-if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then
- tcl_ok=yes
-else
- tcl_ok=no
-fi
-
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -pthread"
- else
- TCL_THREADS=0
- { echo "$as_me:$LINENO: WARNING: Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..." >&5
-echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..." >&2;}
- fi
- fi
- fi
- fi
-
- # Does the pthread-implementation provide
- # 'pthread_attr_setstacksize' ?
-
- ac_saved_libs=$LIBS
- LIBS="$LIBS $THREADS_LIBS"
+if ac_fn_c_try_compile "$LINENO"
+then :
-
-for ac_func in pthread_attr_setstacksize pthread_atfork
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ # This test program should compile successfully.
+ # No library function is consistently available on
+ # freestanding implementations, so test against a dummy
+ # declaration. Include always-available headers on the
+ # off chance that they somehow elicit warnings.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
+#include <float.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <stddef.h>
+extern void ac_decl (int, char *);
int
-main ()
+main (void)
{
-return f != $ac_func;
+(void) ac_decl (0, (char *) 0);
+ (void) ac_decl;
+
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
+if ac_fn_c_try_compile "$LINENO"
+then :
+ if test x"$ac_arg" = x
+then :
+ ac_cv_c_undeclared_builtin_options='none needed'
+else $as_nop
+ ac_cv_c_undeclared_builtin_options=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+ break
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
-
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-done
-
- LIBS=$ac_saved_libs
- else
- TCL_THREADS=0
- fi
- # Do checking message here to not mess up interleaved configure output
- echo "$as_me:$LINENO: checking for building with threads" >&5
-echo $ECHO_N "checking for building with threads... $ECHO_C" >&6
- if test "${TCL_THREADS}" = 1; then
-
-cat >>confdefs.h <<\_ACEOF
-#define TCL_THREADS 1
-_ACEOF
-
- if test "${tcl_threaded_core}" = 1; then
- echo "$as_me:$LINENO: result: yes (threaded core)" >&5
-echo "${ECHO_T}yes (threaded core)" >&6
- else
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
- fi
- else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
- fi
-
-
-
-
-#------------------------------------------------------------------------
-# Embedded configuration information, encoding to use for the values, TIP #59
-#------------------------------------------------------------------------
-
-
-
-# Check whether --with-encoding or --without-encoding was given.
-if test "${with_encoding+set}" = set; then
- withval="$with_encoding"
- with_tcencoding=${withval}
-fi;
-
- if test x"${with_tcencoding}" != x ; then
-
-cat >>confdefs.h <<_ACEOF
-#define TCL_CFGVAL_ENCODING "${with_tcencoding}"
-_ACEOF
-
- else
-
-cat >>confdefs.h <<\_ACEOF
-#define TCL_CFGVAL_ENCODING "iso8859-1"
-_ACEOF
-
- fi
-
-
-#--------------------------------------------------------------------
-# Look for libraries that we will need when compiling the Tcl shell
-#--------------------------------------------------------------------
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ done
+ CFLAGS=$ac_save_CFLAGS
+
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5
+printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; }
+ case $ac_cv_c_undeclared_builtin_options in #(
+ 'cannot detect') :
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot make $CC report undeclared builtins
+See \`config.log' for more details" "$LINENO" 5; } ;; #(
+ 'none needed') :
+ ac_c_undeclared_builtin_options='' ;; #(
+ *) :
+ ac_c_undeclared_builtin_options=$ac_cv_c_undeclared_builtin_options ;;
+esac
#--------------------------------------------------------------------
@@ -4843,99 +4492,11 @@ _ACEOF
# already in libc.a. Set compiler flags accordingly.
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for sin" >&5
-echo $ECHO_N "checking for sin... $ECHO_C" >&6
-if test "${ac_cv_func_sin+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define sin to an innocuous variant, in case <limits.h> declares sin.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define sin innocuous_sin
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char sin (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef sin
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char sin ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_sin) || defined (__stub___sin)
-choke me
-#else
-char (*f) () = sin;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != sin;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_sin=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_sin=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5
-echo "${ECHO_T}$ac_cv_func_sin" >&6
-if test $ac_cv_func_sin = yes; then
+ ac_fn_c_check_func "$LINENO" "sin" "ac_cv_func_sin"
+if test "x$ac_cv_func_sin" = xyes
+then :
MATH_LIBS=""
-else
+else $as_nop
MATH_LIBS="-lm"
fi
@@ -4945,214 +4506,51 @@ fi
# needs net/errno.h to define the socket-related error codes.
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for main in -linet" >&5
-echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6
-if test "${ac_cv_lib_inet_main+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -linet" >&5
+printf %s "checking for main in -linet... " >&6; }
+if test ${ac_cv_lib_inet_main+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-linet $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
-main ();
+return main ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_inet_main=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_inet_main=no
+else $as_nop
+ ac_cv_lib_inet_main=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5
-echo "${ECHO_T}$ac_cv_lib_inet_main" >&6
-if test $ac_cv_lib_inet_main = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_main" >&5
+printf "%s\n" "$ac_cv_lib_inet_main" >&6; }
+if test "x$ac_cv_lib_inet_main" = xyes
+then :
LIBS="$LIBS -linet"
fi
- if test "${ac_cv_header_net_errno_h+set}" = set; then
- echo "$as_me:$LINENO: checking for net/errno.h" >&5
-echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6
-if test "${ac_cv_header_net_errno_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5
-echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking net/errno.h usability" >&5
-echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <net/errno.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ ac_fn_c_check_header_compile "$LINENO" "net/errno.h" "ac_cv_header_net_errno_h" "$ac_includes_default"
+if test "x$ac_cv_header_net_errno_h" = xyes
+then :
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-# Is the header present?
-echo "$as_me:$LINENO: checking net/errno.h presence" >&5
-echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <net/errno.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+printf "%s\n" "#define HAVE_NET_ERRNO_H 1" >>confdefs.h
- ac_header_preproc=no
fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: net/errno.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: net/errno.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: net/errno.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: net/errno.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: net/errno.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for net/errno.h" >&5
-echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6
-if test "${ac_cv_header_net_errno_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_net_errno_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5
-echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6
-
-fi
-if test $ac_cv_header_net_errno_h = yes; then
-
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NET_ERRNO_H 1
-_ACEOF
-
-fi
-
#--------------------------------------------------------------------
@@ -5174,559 +4572,432 @@ fi
#--------------------------------------------------------------------
tcl_checkBoth=0
- echo "$as_me:$LINENO: checking for connect" >&5
-echo $ECHO_N "checking for connect... $ECHO_C" >&6
-if test "${ac_cv_func_connect+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect"
+if test "x$ac_cv_func_connect" = xyes
+then :
+ tcl_checkSocket=0
+else $as_nop
+ tcl_checkSocket=1
+fi
+
+ if test "$tcl_checkSocket" = 1; then
+ ac_fn_c_check_func "$LINENO" "setsockopt" "ac_cv_func_setsockopt"
+if test "x$ac_cv_func_setsockopt" = xyes
+then :
+
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for setsockopt in -lsocket" >&5
+printf %s "checking for setsockopt in -lsocket... " >&6; }
+if test ${ac_cv_lib_socket_setsockopt+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lsocket $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Define connect to an innocuous variant, in case <limits.h> declares connect.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define connect innocuous_connect
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char connect (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+char setsockopt ();
+int
+main (void)
+{
+return setsockopt ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_socket_setsockopt=yes
+else $as_nop
+ ac_cv_lib_socket_setsockopt=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_setsockopt" >&5
+printf "%s\n" "$ac_cv_lib_socket_setsockopt" >&6; }
+if test "x$ac_cv_lib_socket_setsockopt" = xyes
+then :
+ LIBS="$LIBS -lsocket"
+else $as_nop
+ tcl_checkBoth=1
+fi
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+fi
-#undef connect
+ fi
+ if test "$tcl_checkBoth" = 1; then
+ tk_oldLibs=$LIBS
+ LIBS="$LIBS -lsocket -lnsl"
+ ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept"
+if test "x$ac_cv_func_accept" = xyes
+then :
+ tcl_checkNsl=0
+else $as_nop
+ LIBS=$tk_oldLibs
+fi
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char connect ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_connect) || defined (__stub___connect)
-choke me
-#else
-char (*f) () = connect;
-#endif
-#ifdef __cplusplus
-}
-#endif
+ fi
+ ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname"
+if test "x$ac_cv_func_gethostbyname" = xyes
+then :
+
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnsl" >&5
+printf %s "checking for gethostbyname in -lnsl... " >&6; }
+if test ${ac_cv_lib_nsl_gethostbyname+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lnsl $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+char gethostbyname ();
int
-main ()
+main (void)
{
-return f != connect;
+return gethostbyname ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_connect=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_connect=no
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_nsl_gethostbyname=yes
+else $as_nop
+ ac_cv_lib_nsl_gethostbyname=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5
-echo "${ECHO_T}$ac_cv_func_connect" >&6
-if test $ac_cv_func_connect = yes; then
- tcl_checkSocket=0
-else
- tcl_checkSocket=1
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostbyname" >&5
+printf "%s\n" "$ac_cv_lib_nsl_gethostbyname" >&6; }
+if test "x$ac_cv_lib_nsl_gethostbyname" = xyes
+then :
+ LIBS="$LIBS -lnsl"
fi
- if test "$tcl_checkSocket" = 1; then
- echo "$as_me:$LINENO: checking for setsockopt" >&5
-echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6
-if test "${ac_cv_func_setsockopt+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define setsockopt to an innocuous variant, in case <limits.h> declares setsockopt.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define setsockopt innocuous_setsockopt
+fi
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char setsockopt (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-#undef setsockopt
+printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char setsockopt ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_setsockopt) || defined (__stub___setsockopt)
-choke me
-#else
-char (*f) () = setsockopt;
-#endif
-#ifdef __cplusplus
-}
-#endif
+printf "%s\n" "#define _THREAD_SAFE 1" >>confdefs.h
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5
+printf %s "checking for pthread_mutex_init in -lpthread... " >&6; }
+if test ${ac_cv_lib_pthread_pthread_mutex_init+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lpthread $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+char pthread_mutex_init ();
int
-main ()
+main (void)
{
-return f != setsockopt;
+return pthread_mutex_init ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_setsockopt=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_setsockopt=no
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_pthread_pthread_mutex_init=yes
+else $as_nop
+ ac_cv_lib_pthread_pthread_mutex_init=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5
-echo "${ECHO_T}$ac_cv_func_setsockopt" >&6
-if test $ac_cv_func_setsockopt = yes; then
- :
-else
- echo "$as_me:$LINENO: checking for setsockopt in -lsocket" >&5
-echo $ECHO_N "checking for setsockopt in -lsocket... $ECHO_C" >&6
-if test "${ac_cv_lib_socket_setsockopt+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
+printf "%s\n" "$ac_cv_lib_pthread_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes
+then :
+ tcl_ok=yes
+else $as_nop
+ tcl_ok=no
+fi
+
+ if test "$tcl_ok" = "no"; then
+ # Check a little harder for __pthread_mutex_init in the same
+ # library, as some systems hide it there until pthread.h is
+ # defined. We could alternatively do an AC_TRY_COMPILE with
+ # pthread.h, but that will work with libpthread really doesn't
+ # exist, like AIX 4.2. [Bug: 4359]
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5
+printf %s "checking for __pthread_mutex_init in -lpthread... " >&6; }
+if test ${ac_cv_lib_pthread___pthread_mutex_init+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
-LIBS="-lsocket $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+LIBS="-lpthread $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
-char setsockopt ();
+char __pthread_mutex_init ();
int
-main ()
+main (void)
{
-setsockopt ();
+return __pthread_mutex_init ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_socket_setsockopt=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_socket_setsockopt=no
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_pthread___pthread_mutex_init=yes
+else $as_nop
+ ac_cv_lib_pthread___pthread_mutex_init=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5
-echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6
-if test $ac_cv_lib_socket_setsockopt = yes; then
- LIBS="$LIBS -lsocket"
-else
- tcl_checkBoth=1
-fi
-
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
+printf "%s\n" "$ac_cv_lib_pthread___pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes
+then :
+ tcl_ok=yes
+else $as_nop
+ tcl_ok=no
fi
fi
- if test "$tcl_checkBoth" = 1; then
- tk_oldLibs=$LIBS
- LIBS="$LIBS -lsocket -lnsl"
- echo "$as_me:$LINENO: checking for accept" >&5
-echo $ECHO_N "checking for accept... $ECHO_C" >&6
-if test "${ac_cv_func_accept+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define accept to an innocuous variant, in case <limits.h> declares accept.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define accept innocuous_accept
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char accept (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef accept
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -lpthread"
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5
+printf %s "checking for pthread_mutex_init in -lpthreads... " >&6; }
+if test ${ac_cv_lib_pthreads_pthread_mutex_init+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lpthreads $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
-char accept ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_accept) || defined (__stub___accept)
-choke me
-#else
-char (*f) () = accept;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
+char pthread_mutex_init ();
int
-main ()
+main (void)
{
-return f != accept;
+return pthread_mutex_init ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_accept=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_accept=no
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_pthreads_pthread_mutex_init=yes
+else $as_nop
+ ac_cv_lib_pthreads_pthread_mutex_init=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5
-echo "${ECHO_T}$ac_cv_func_accept" >&6
-if test $ac_cv_func_accept = yes; then
- tcl_checkNsl=0
-else
- LIBS=$tk_oldLibs
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
+printf "%s\n" "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes
+then :
+ _ok=yes
+else $as_nop
+ tcl_ok=no
fi
- fi
- echo "$as_me:$LINENO: checking for gethostbyname" >&5
-echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6
-if test "${ac_cv_func_gethostbyname+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -lpthreads"
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5
+printf %s "checking for pthread_mutex_init in -lc... " >&6; }
+if test ${ac_cv_lib_c_pthread_mutex_init+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lc $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Define gethostbyname to an innocuous variant, in case <limits.h> declares gethostbyname.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define gethostbyname innocuous_gethostbyname
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char gethostbyname (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-#undef gethostbyname
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
-char gethostbyname ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_gethostbyname) || defined (__stub___gethostbyname)
-choke me
-#else
-char (*f) () = gethostbyname;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
+char pthread_mutex_init ();
int
-main ()
+main (void)
{
-return f != gethostbyname;
+return pthread_mutex_init ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_gethostbyname=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_gethostbyname=no
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_c_pthread_mutex_init=yes
+else $as_nop
+ ac_cv_lib_c_pthread_mutex_init=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5
-echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6
-if test $ac_cv_func_gethostbyname = yes; then
- :
-else
- echo "$as_me:$LINENO: checking for gethostbyname in -lnsl" >&5
-echo $ECHO_N "checking for gethostbyname in -lnsl... $ECHO_C" >&6
-if test "${ac_cv_lib_nsl_gethostbyname+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5
+printf "%s\n" "$ac_cv_lib_c_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes
+then :
+ tcl_ok=yes
+else $as_nop
+ tcl_ok=no
+fi
+
+ if test "$tcl_ok" = "no"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5
+printf %s "checking for pthread_mutex_init in -lc_r... " >&6; }
+if test ${ac_cv_lib_c_r_pthread_mutex_init+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
-LIBS="-lnsl $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+LIBS="-lc_r $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
-char gethostbyname ();
+char pthread_mutex_init ();
int
-main ()
+main (void)
{
-gethostbyname ();
+return pthread_mutex_init ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_lib_nsl_gethostbyname=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_nsl_gethostbyname=no
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_c_r_pthread_mutex_init=yes
+else $as_nop
+ ac_cv_lib_c_r_pthread_mutex_init=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5
-echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6
-if test $ac_cv_lib_nsl_gethostbyname = yes; then
- LIBS="$LIBS -lnsl"
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
+printf "%s\n" "$ac_cv_lib_c_r_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_c_r_pthread_mutex_init" = xyes
+then :
+ tcl_ok=yes
+else $as_nop
+ tcl_ok=no
+fi
+
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -pthread"
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&5
+printf "%s\n" "$as_me: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&2;}
+ fi
+ fi
+ fi
+ fi
+
+ # Does the pthread-implementation provide
+ # 'pthread_attr_setstacksize' ?
+
+ ac_saved_libs=$LIBS
+ LIBS="$LIBS $THREADS_LIBS"
+ ac_fn_c_check_func "$LINENO" "pthread_attr_setstacksize" "ac_cv_func_pthread_attr_setstacksize"
+if test "x$ac_cv_func_pthread_attr_setstacksize" = xyes
+then :
+ printf "%s\n" "#define HAVE_PTHREAD_ATTR_SETSTACKSIZE 1" >>confdefs.h
+
fi
+ac_fn_c_check_func "$LINENO" "pthread_atfork" "ac_cv_func_pthread_atfork"
+if test "x$ac_cv_func_pthread_atfork" = xyes
+then :
+ printf "%s\n" "#define HAVE_PTHREAD_ATFORK 1" >>confdefs.h
fi
+ LIBS=$ac_saved_libs
+
+ # TIP #509
+ ac_fn_check_decl "$LINENO" "PTHREAD_MUTEX_RECURSIVE" "ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" "#include <pthread.h>
+" "$ac_c_undeclared_builtin_options" "CFLAGS"
+if test "x$ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" = xyes
+then :
+ ac_have_decl=1
+else $as_nop
+ ac_have_decl=0
+fi
+printf "%s\n" "#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE $ac_have_decl" >>confdefs.h
+if test $ac_have_decl = 1
+then :
+ tcl_ok=yes
+else $as_nop
+ tcl_ok=no
+fi
+
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
- echo "$as_me:$LINENO: checking how to build libraries" >&5
-echo $ECHO_N "checking how to build libraries... $ECHO_C" >&6
- # Check whether --enable-shared or --disable-shared was given.
-if test "${enable_shared+set}" = set; then
- enableval="$enable_shared"
- tcl_ok=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
+printf %s "checking how to build libraries... " >&6; }
+ # Check whether --enable-shared was given.
+if test ${enable_shared+y}
+then :
+ enableval=$enable_shared; tcl_ok=$enableval
+else $as_nop
tcl_ok=yes
-fi;
+fi
+
if test "$tcl_ok" = "yes" ; then
- echo "$as_me:$LINENO: result: shared" >&5
-echo "${ECHO_T}shared" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5
+printf "%s\n" "shared" >&6; }
SHARED_BUILD=1
else
- echo "$as_me:$LINENO: result: static" >&5
-echo "${ECHO_T}static" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5
+printf "%s\n" "static" >&6; }
SHARED_BUILD=0
-cat >>confdefs.h <<\_ACEOF
-#define STATIC_BUILD 1
-_ACEOF
+printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h
fi
@@ -5739,11 +5010,12 @@ _ACEOF
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for tclsh" >&5
-echo $ECHO_N "checking for tclsh... $ECHO_C" >&6
- if test "${ac_cv_path_tclsh+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
+printf %s "checking for tclsh... " >&6; }
+ if test ${ac_cv_path_tclsh+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
@@ -5763,13 +5035,13 @@ fi
if test -f "$ac_cv_path_tclsh" ; then
TCLSH_PROG="$ac_cv_path_tclsh"
- echo "$as_me:$LINENO: result: $TCLSH_PROG" >&5
-echo "${ECHO_T}$TCLSH_PROG" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
+printf "%s\n" "$TCLSH_PROG" >&6; }
else
# It is not an error if an installed version of Tcl can't be located.
TCLSH_PROG=""
- echo "$as_me:$LINENO: result: No tclsh found on PATH" >&5
-echo "${ECHO_T}No tclsh found on PATH" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
+printf "%s\n" "No tclsh found on PATH" >&6; }
fi
@@ -5782,364 +5054,201 @@ fi
#------------------------------------------------------------------------
zlib_ok=yes
-if test "${ac_cv_header_zlib_h+set}" = set; then
- echo "$as_me:$LINENO: checking for zlib.h" >&5
-echo $ECHO_N "checking for zlib.h... $ECHO_C" >&6
-if test "${ac_cv_header_zlib_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_zlib_h" >&5
-echo "${ECHO_T}$ac_cv_header_zlib_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking zlib.h usability" >&5
-echo $ECHO_N "checking zlib.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <zlib.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_header_compile "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default"
+if test "x$ac_cv_header_zlib_h" = xyes
+then :
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
+ ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include <zlib.h>
+"
+if test "x$ac_cv_type_gz_header" = xyes
+then :
-# Is the header present?
-echo "$as_me:$LINENO: checking zlib.h presence" >&5
-echo $ECHO_N "checking zlib.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <zlib.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
+else $as_nop
+ zlib_ok=no
fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
+else $as_nop
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: zlib.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: zlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: zlib.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: zlib.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: zlib.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: zlib.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: zlib.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: zlib.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: zlib.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: zlib.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: zlib.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: zlib.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: zlib.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: zlib.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: zlib.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: zlib.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for zlib.h" >&5
-echo $ECHO_N "checking for zlib.h... $ECHO_C" >&6
-if test "${ac_cv_header_zlib_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_zlib_h=$ac_header_preproc
+ zlib_ok=no
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_zlib_h" >&5
-echo "${ECHO_T}$ac_cv_header_zlib_h" >&6
-fi
-if test $ac_cv_header_zlib_h = yes; then
+if test $zlib_ok = yes
+then :
- echo "$as_me:$LINENO: checking for gz_header" >&5
-echo $ECHO_N "checking for gz_header... $ECHO_C" >&6
-if test "${ac_cv_type_gz_header+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5
+printf %s "checking for library containing deflateSetHeader... " >&6; }
+if test ${ac_cv_search_deflateSetHeader+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_func_search_save_LIBS=$LIBS
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-#include <zlib.h>
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
+ builtin and then its argument prototype would still apply. */
+char deflateSetHeader ();
int
-main ()
+main (void)
{
-if ((gz_header *) 0)
- return 0;
-if (sizeof (gz_header))
- return 0;
+return deflateSetHeader ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_gz_header=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+for ac_lib in '' z
+do
+ if test -z "$ac_lib"; then
+ ac_res="none required"
+ else
+ ac_res=-l$ac_lib
+ LIBS="-l$ac_lib $ac_func_search_save_LIBS"
+ fi
+ if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_search_deflateSetHeader=$ac_res
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext
+ if test ${ac_cv_search_deflateSetHeader+y}
+then :
+ break
+fi
+done
+if test ${ac_cv_search_deflateSetHeader+y}
+then :
-ac_cv_type_gz_header=no
+else $as_nop
+ ac_cv_search_deflateSetHeader=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm conftest.$ac_ext
+LIBS=$ac_func_search_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_type_gz_header" >&5
-echo "${ECHO_T}$ac_cv_type_gz_header" >&6
-if test $ac_cv_type_gz_header = yes; then
- :
-else
- zlib_ok=no
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5
+printf "%s\n" "$ac_cv_search_deflateSetHeader" >&6; }
+ac_res=$ac_cv_search_deflateSetHeader
+if test "$ac_res" != no
+then :
+ test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"
+
+else $as_nop
+
+ zlib_ok=no
+
fi
-else
+fi
+if test $zlib_ok = no
+then :
+
+ ZLIB_OBJS=\${ZLIB_OBJS}
+
+ ZLIB_SRCS=\${ZLIB_SRCS}
+
+ ZLIB_INCLUDE=-I\${ZLIB_DIR}
+
- zlib_ok=no
fi
+printf "%s\n" "#define HAVE_ZLIB 1" >>confdefs.h
-if test $zlib_ok = yes; then
- echo "$as_me:$LINENO: checking for library containing deflateSetHeader" >&5
-echo $ECHO_N "checking for library containing deflateSetHeader... $ECHO_C" >&6
-if test "${ac_cv_search_deflateSetHeader+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_func_search_save_LIBS=$LIBS
-ac_cv_search_deflateSetHeader=no
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
+#------------------------------------------------------------------------
+# Add stuff for libtommath
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char deflateSetHeader ();
-int
-main ()
-{
-deflateSetHeader ();
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_search_deflateSetHeader="none required"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+libtommath_ok=yes
+# Check whether --with-system-libtommath was given.
+if test ${with_system_libtommath+y}
+then :
+ withval=$with_system_libtommath; libtommath_ok=${withval}
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-if test "$ac_cv_search_deflateSetHeader" = no; then
- for ac_lib in z; do
- LIBS="-l$ac_lib $ac_func_search_save_LIBS"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+
+if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
+ ac_fn_c_check_header_compile "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default"
+if test "x$ac_cv_header_tommath_h" = xyes
+then :
+
+ ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include <tommath.h>
+"
+if test "x$ac_cv_type_mp_int" = xyes
+then :
+
+else $as_nop
+ libtommath_ok=no
+fi
+
+else $as_nop
+
+ libtommath_ok=no
+fi
+
+ if test $libtommath_ok = yes
+then :
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5
+printf %s "checking for mp_log_u32 in -ltommath... " >&6; }
+if test ${ac_cv_lib_tommath_mp_log_u32+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-ltommath $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
-char deflateSetHeader ();
+char mp_log_u32 ();
int
-main ()
+main (void)
{
-deflateSetHeader ();
+return mp_log_u32 ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_search_deflateSetHeader="-l$ac_lib"
-break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
- done
+if ac_fn_c_try_link "$LINENO"
+then :
+ ac_cv_lib_tommath_mp_log_u32=yes
+else $as_nop
+ ac_cv_lib_tommath_mp_log_u32=no
fi
-LIBS=$ac_func_search_save_LIBS
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_search_deflateSetHeader" >&5
-echo "${ECHO_T}$ac_cv_search_deflateSetHeader" >&6
-if test "$ac_cv_search_deflateSetHeader" != no; then
- test "$ac_cv_search_deflateSetHeader" = "none required" || LIBS="$ac_cv_search_deflateSetHeader $LIBS"
-
-else
-
- zlib_ok=no
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5
+printf "%s\n" "$ac_cv_lib_tommath_mp_log_u32" >&6; }
+if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes
+then :
+ MATH_LIBS="$MATH_LIBS -ltommath"
+else $as_nop
+ libtommath_ok=no
fi
fi
+fi
+if test $libtommath_ok = yes
+then :
-if test $zlib_ok = no; then
- ZLIB_OBJS=\${ZLIB_OBJS}
+printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
- ZLIB_SRCS=\${ZLIB_SRCS}
- ZLIB_INCLUDE=-I\${ZLIB_DIR}
+else $as_nop
+ TOMMATH_OBJS=\${TOMMATH_OBJS}
-fi
+ TOMMATH_SRCS=\${TOMMATH_SRCS}
+ TOMMATH_INCLUDE=-I\${TOMMATH_DIR}
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_ZLIB 1
-_ACEOF
+fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
@@ -6150,11 +5259,12 @@ _ACEOF
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
set dummy ${ac_tool_prefix}ranlib; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_RANLIB+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_RANLIB+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
@@ -6162,37 +5272,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
RANLIB=$ac_cv_prog_RANLIB
if test -n "$RANLIB"; then
- echo "$as_me:$LINENO: result: $RANLIB" >&5
-echo "${ECHO_T}$RANLIB" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
+printf "%s\n" "$RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_RANLIB"; then
ac_ct_RANLIB=$RANLIB
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_RANLIB+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_RANLIB"; then
ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
else
@@ -6200,29 +5317,43 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RANLIB="ranlib"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
- test -z "$ac_cv_prog_ac_ct_RANLIB" && ac_cv_prog_ac_ct_RANLIB=":"
fi
fi
ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB
if test -n "$ac_ct_RANLIB"; then
- echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5
-echo "${ECHO_T}$ac_ct_RANLIB" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
+printf "%s\n" "$ac_ct_RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- RANLIB=$ac_ct_RANLIB
+ if test "x$ac_ct_RANLIB" = x; then
+ RANLIB=":"
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ RANLIB=$ac_ct_RANLIB
+ fi
else
RANLIB="$ac_cv_prog_RANLIB"
fi
@@ -6231,154 +5362,122 @@ fi
# Step 0.a: Enable 64 bit support?
- echo "$as_me:$LINENO: checking if 64bit support is requested" >&5
-echo $ECHO_N "checking if 64bit support is requested... $ECHO_C" >&6
- # Check whether --enable-64bit or --disable-64bit was given.
-if test "${enable_64bit+set}" = set; then
- enableval="$enable_64bit"
- do64bit=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
+printf %s "checking if 64bit support is requested... " >&6; }
+ # Check whether --enable-64bit was given.
+if test ${enable_64bit+y}
+then :
+ enableval=$enable_64bit; do64bit=$enableval
+else $as_nop
do64bit=no
-fi;
- echo "$as_me:$LINENO: result: $do64bit" >&5
-echo "${ECHO_T}$do64bit" >&6
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
+printf "%s\n" "$do64bit" >&6; }
# Step 0.b: Enable Solaris 64 bit VIS support?
- echo "$as_me:$LINENO: checking if 64bit Sparc VIS support is requested" >&5
-echo $ECHO_N "checking if 64bit Sparc VIS support is requested... $ECHO_C" >&6
- # Check whether --enable-64bit-vis or --disable-64bit-vis was given.
-if test "${enable_64bit_vis+set}" = set; then
- enableval="$enable_64bit_vis"
- do64bitVIS=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit Sparc VIS support is requested" >&5
+printf %s "checking if 64bit Sparc VIS support is requested... " >&6; }
+ # Check whether --enable-64bit-vis was given.
+if test ${enable_64bit_vis+y}
+then :
+ enableval=$enable_64bit_vis; do64bitVIS=$enableval
+else $as_nop
do64bitVIS=no
-fi;
- echo "$as_me:$LINENO: result: $do64bitVIS" >&5
-echo "${ECHO_T}$do64bitVIS" >&6
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bitVIS" >&5
+printf "%s\n" "$do64bitVIS" >&6; }
# Force 64bit on with VIS
- if test "$do64bitVIS" = "yes"; then
+ if test "$do64bitVIS" = "yes"
+then :
do64bit=yes
fi
-
# Step 0.c: Check if visibility support is available. Do this here so
# that platform specific alternatives can be used below if this fails.
- echo "$as_me:$LINENO: checking if compiler supports visibility \"hidden\"" >&5
-echo $ECHO_N "checking if compiler supports visibility \"hidden\"... $ECHO_C" >&6
-if test "${tcl_cv_cc_visibility_hidden+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler supports visibility \"hidden\"" >&5
+printf %s "checking if compiler supports visibility \"hidden\"... " >&6; }
+if test ${tcl_cv_cc_visibility_hidden+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
extern __attribute__((__visibility__("hidden"))) void f(void);
void f(void) {}
int
-main ()
+main (void)
{
f();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cc_visibility_hidden=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_visibility_hidden=no
+else $as_nop
+ tcl_cv_cc_visibility_hidden=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5
-echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6
- if test $tcl_cv_cc_visibility_hidden = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_visibility_hidden" >&5
+printf "%s\n" "$tcl_cv_cc_visibility_hidden" >&6; }
+ if test $tcl_cv_cc_visibility_hidden = yes
+then :
-cat >>confdefs.h <<\_ACEOF
-#define MODULE_SCOPE extern __attribute__((__visibility__("hidden")))
-_ACEOF
+printf "%s\n" "#define MODULE_SCOPE extern __attribute__((__visibility__(\"hidden\")))" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_HIDDEN 1
-_ACEOF
+printf "%s\n" "#define HAVE_HIDDEN 1" >>confdefs.h
fi
-
# Step 0.d: Disable -rpath support?
- echo "$as_me:$LINENO: checking if rpath support is requested" >&5
-echo $ECHO_N "checking if rpath support is requested... $ECHO_C" >&6
- # Check whether --enable-rpath or --disable-rpath was given.
-if test "${enable_rpath+set}" = set; then
- enableval="$enable_rpath"
- doRpath=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if rpath support is requested" >&5
+printf %s "checking if rpath support is requested... " >&6; }
+ # Check whether --enable-rpath was given.
+if test ${enable_rpath+y}
+then :
+ enableval=$enable_rpath; doRpath=$enableval
+else $as_nop
doRpath=yes
-fi;
- echo "$as_me:$LINENO: result: $doRpath" >&5
-echo "${ECHO_T}$doRpath" >&6
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5
+printf "%s\n" "$doRpath" >&6; }
# Step 1: set the variable "system" to hold the name and version number
# for the system.
- echo "$as_me:$LINENO: checking system version" >&5
-echo $ECHO_N "checking system version... $ECHO_C" >&6
-if test "${tcl_cv_sys_version+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5
+printf %s "checking system version... " >&6; }
+if test ${tcl_cv_sys_version+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- if test -f /usr/lib/NextStep/software_version; then
- tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
+ if test "${TEA_PLATFORM}" = "windows" ; then
+ tcl_cv_sys_version=windows
else
tcl_cv_sys_version=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
- { echo "$as_me:$LINENO: WARNING: can't find uname command" >&5
-echo "$as_me: WARNING: can't find uname command" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
+printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
- # Special check for weird MP-RAS system (uname returns weird
- # results, and the version is kept in special file).
-
- if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
- tcl_cv_sys_version=MP-RAS-`awk '{print $3}' /etc/.relid`
- fi
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
@@ -6389,81 +5488,53 @@ echo "$as_me: WARNING: can't find uname command" >&2;}
fi
fi
-echo "$as_me:$LINENO: result: $tcl_cv_sys_version" >&5
-echo "${ECHO_T}$tcl_cv_sys_version" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
+printf "%s\n" "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
- echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5
-echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6
-if test "${ac_cv_lib_dl_dlopen+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
+printf %s "checking for dlopen in -ldl... " >&6; }
+if test ${ac_cv_lib_dl_dlopen+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ldl $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char dlopen ();
int
-main ()
+main (void)
{
-dlopen ();
+return dlopen ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_dl_dlopen=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_dl_dlopen=no
+else $as_nop
+ ac_cv_lib_dl_dlopen=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5
-echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6
-if test $ac_cv_lib_dl_dlopen = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5
+printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; }
+if test "x$ac_cv_lib_dl_dlopen" = xyes
+then :
have_dl=yes
-else
+else $as_nop
have_dl=no
fi
@@ -6487,26 +5558,35 @@ fi
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
CFLAGS_OPTIMIZE=-O2
- CFLAGS_WARNING="-Wall -Wpointer-arith"
+ CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith"
+ case "${CC}" in
+ *++|*++-*)
+ ;;
+ *)
+ CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers"
+ ;;
+ esac
-else
+
+else $as_nop
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
fi
-
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args.
set dummy ${ac_tool_prefix}ar; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_AR+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_AR+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
else
@@ -6514,37 +5594,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_AR="${ac_tool_prefix}ar"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
AR=$ac_cv_prog_AR
if test -n "$AR"; then
- echo "$as_me:$LINENO: result: $AR" >&5
-echo "${ECHO_T}$AR" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
+printf "%s\n" "$AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_AR"; then
ac_ct_AR=$AR
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_AR+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_AR+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_AR"; then
ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
else
@@ -6552,28 +5639,43 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_AR="ar"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_AR=$ac_cv_prog_ac_ct_AR
if test -n "$ac_ct_AR"; then
- echo "$as_me:$LINENO: result: $ac_ct_AR" >&5
-echo "${ECHO_T}$ac_ct_AR" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
+printf "%s\n" "$ac_ct_AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- AR=$ac_ct_AR
+ if test "x$ac_ct_AR" = x; then
+ AR=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ AR=$ac_ct_AR
+ fi
else
AR="$ac_cv_prog_AR"
fi
@@ -6583,15 +5685,14 @@ fi
PLAT_OBJS=""
PLAT_SRCS=""
LDAIX_SRC=""
- if test "x${SHLIB_VERSION}" = x; then
- SHLIB_VERSION=".1.0"
-else
- SHLIB_VERSION=".${SHLIB_VERSION}"
+ if test "x${SHLIB_VERSION}" = x
+then :
+ SHLIB_VERSION="1.0"
fi
-
case $system in
AIX-*)
- if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"; then
+ if test "$GCC" != "yes"
+then :
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
@@ -6603,11 +5704,10 @@ fi
CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'`
;;
esac
- echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5
-echo "${ECHO_T}Using $CC for compiling with threads" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5
+printf "%s\n" "Using $CC for compiling with threads" >&6; }
fi
-
LIBS="$LIBS -lc"
SHLIB_CFLAGS=""
SHLIB_SUFFIX=".so"
@@ -6620,14 +5720,16 @@ fi
LDAIX_SRC='$(UNIX_DIR)/ldAix'
# Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = yes; then
+ if test "$do64bit" = yes
+then :
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
- { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5
-echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
+printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
-else
+else $as_nop
do64bit_ok=yes
CFLAGS="$CFLAGS -q64"
@@ -6638,48 +5740,46 @@ else
fi
-
fi
-
- if test "`uname -m`" = ia64; then
+ if test "`uname -m`" = ia64
+then :
# AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
# AIX-5 has dl* in libc.so
DL_LIBS=""
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
-else
+else $as_nop
CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
fi
-
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
-else
+else $as_nop
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
SHLIB_LD='${CC} -shared -Wl,-bexpall'
-else
+else $as_nop
SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry"
LDFLAGS="$LDFLAGS -brtl"
fi
-
SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
fi
-
;;
BeOS*)
SHLIB_CFLAGS="-fPIC"
@@ -6693,71 +5793,43 @@ fi
# -lsocket, even if the network functions are in -lnet which
# is always linked to, for compatibility.
#-----------------------------------------------------------
- echo "$as_me:$LINENO: checking for inet_ntoa in -lbind" >&5
-echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6
-if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lbind" >&5
+printf %s "checking for inet_ntoa in -lbind... " >&6; }
+if test ${ac_cv_lib_bind_inet_ntoa+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbind $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char inet_ntoa ();
int
-main ()
+main (void)
{
-inet_ntoa ();
+return inet_ntoa ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_bind_inet_ntoa=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_bind_inet_ntoa=no
+else $as_nop
+ ac_cv_lib_bind_inet_ntoa=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5
-echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6
-if test $ac_cv_lib_bind_inet_ntoa = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bind_inet_ntoa" >&5
+printf "%s\n" "$ac_cv_lib_bind_inet_ntoa" >&6; }
+if test "x$ac_cv_lib_bind_inet_ntoa" = xyes
+then :
LIBS="$LIBS -lbind -lsocket"
fi
@@ -6794,16 +5866,13 @@ fi
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a'
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a"
- echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
-echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
-if test "${ac_cv_cygwin+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5
+printf %s "checking for Cygwin version of gcc... " >&6; }
+if test ${ac_cv_cygwin+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef __CYGWIN__
@@ -6811,56 +5880,26 @@ cat >>conftest.$ac_ext <<_ACEOF
#endif
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_cygwin=no
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_cygwin=yes
+else $as_nop
+ ac_cv_cygwin=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
-echo "${ECHO_T}$ac_cv_cygwin" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5
+printf "%s\n" "$ac_cv_cygwin" >&6; }
if test "$ac_cv_cygwin" = "no"; then
- { { echo "$as_me:$LINENO: error: ${CC} is not a cygwin compiler." >&5
-echo "$as_me: error: ${CC} is not a cygwin compiler." >&2;}
- { (exit 1); exit 1; }; }
- fi
- if test "x${TCL_THREADS}" = "x0"; then
- { { echo "$as_me:$LINENO: error: CYGWIN compile is only supported with --enable-threads" >&5
-echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;}
- { (exit 1); exit 1; }; }
+ as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5
fi
do64bit_ok=yes
if test "x${SHARED_BUILD}" = "x1"; then
@@ -6890,71 +5929,43 @@ echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-lroot"
- echo "$as_me:$LINENO: checking for inet_ntoa in -lnetwork" >&5
-echo $ECHO_N "checking for inet_ntoa in -lnetwork... $ECHO_C" >&6
-if test "${ac_cv_lib_network_inet_ntoa+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5
+printf %s "checking for inet_ntoa in -lnetwork... " >&6; }
+if test ${ac_cv_lib_network_inet_ntoa+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lnetwork $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char inet_ntoa ();
int
-main ()
+main (void)
{
-inet_ntoa ();
+return inet_ntoa ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_network_inet_ntoa=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_network_inet_ntoa=no
+else $as_nop
+ ac_cv_lib_network_inet_ntoa=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_network_inet_ntoa" >&5
-echo "${ECHO_T}$ac_cv_lib_network_inet_ntoa" >&6
-if test $ac_cv_lib_network_inet_ntoa = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_inet_ntoa" >&5
+printf "%s\n" "$ac_cv_lib_network_inet_ntoa" >&6; }
+if test "x$ac_cv_lib_network_inet_ntoa" = xyes
+then :
LIBS="$LIBS -lnetwork"
fi
@@ -6962,98 +5973,67 @@ fi
HP-UX-*.11.*)
# Use updated header definitions where possible
-cat >>confdefs.h <<\_ACEOF
-#define _XOPEN_SOURCE_EXTENDED 1
-_ACEOF
+printf "%s\n" "#define _XOPEN_SOURCE_EXTENDED 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define _XOPEN_SOURCE 1
-_ACEOF
+printf "%s\n" "#define _XOPEN_SOURCE 1" >>confdefs.h
LIBS="$LIBS -lxnet" # Use the XOPEN network library
- if test "`uname -m`" = ia64; then
+ if test "`uname -m`" = ia64
+then :
SHLIB_SUFFIX=".so"
-else
+else $as_nop
SHLIB_SUFFIX=".sl"
fi
-
- echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5
-echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6
-if test "${ac_cv_lib_dld_shl_load+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
+printf %s "checking for shl_load in -ldld... " >&6; }
+if test ${ac_cv_lib_dld_shl_load+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char shl_load ();
int
-main ()
+main (void)
{
-shl_load ();
+return shl_load ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_dld_shl_load=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_dld_shl_load=no
+else $as_nop
+ ac_cv_lib_dld_shl_load=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5
-echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6
-if test $ac_cv_lib_dld_shl_load = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
+printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; }
+if test "x$ac_cv_lib_dld_shl_load" = xyes
+then :
tcl_ok=yes
-else
+else $as_nop
tcl_ok=no
fi
- if test "$tcl_ok" = yes; then
+ if test "$tcl_ok" = yes
+then :
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
@@ -7065,46 +6045,47 @@ fi
LD_LIBRARY_PATH_VAR="SHLIB_PATH"
fi
-
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
SHLIB_LD='${CC} -shared'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
-else
+else $as_nop
CFLAGS="$CFLAGS -z"
fi
-
# Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
#CFLAGS="$CFLAGS +DAportable"
# Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = "yes"; then
+ if test "$do64bit" = "yes"
+then :
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
-
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
- { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5
-echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
+printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
;;
esac
-else
+else $as_nop
do64bit_ok=yes
CFLAGS="$CFLAGS +DD64"
@@ -7112,82 +6093,53 @@ else
fi
-
-fi
- ;;
+fi ;;
HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
SHLIB_SUFFIX=".sl"
- echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5
-echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6
-if test "${ac_cv_lib_dld_shl_load+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
+printf %s "checking for shl_load in -ldld... " >&6; }
+if test ${ac_cv_lib_dld_shl_load+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char shl_load ();
int
-main ()
+main (void)
{
-shl_load ();
+return shl_load ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_dld_shl_load=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_dld_shl_load=no
+else $as_nop
+ ac_cv_lib_dld_shl_load=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5
-echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6
-if test $ac_cv_lib_dld_shl_load = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
+printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; }
+if test "x$ac_cv_lib_dld_shl_load" = xyes
+then :
tcl_ok=yes
-else
+else $as_nop
tcl_ok=no
fi
- if test "$tcl_ok" = yes; then
+ if test "$tcl_ok" = yes
+then :
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
@@ -7199,28 +6151,25 @@ fi
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
LD_LIBRARY_PATH_VAR="SHLIB_PATH"
-fi
- ;;
+fi ;;
IRIX-5.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- case $LIBOBJS in
- "mkstemp.$ac_objext" | \
- *" mkstemp.$ac_objext" | \
- "mkstemp.$ac_objext "* | \
+ case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
+ ;;
esac
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
-
;;
IRIX-6.*)
SHLIB_CFLAGS=""
@@ -7228,26 +6177,25 @@ fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- case $LIBOBJS in
- "mkstemp.$ac_objext" | \
- *" mkstemp.$ac_objext" | \
- "mkstemp.$ac_objext "* | \
+ case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
+ ;;
esac
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
-
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
-else
+else $as_nop
case $system in
IRIX-6.3)
@@ -7261,7 +6209,6 @@ else
LDFLAGS="$LDFLAGS -n32"
fi
-
;;
IRIX64-6.*)
SHLIB_CFLAGS=""
@@ -7269,31 +6216,31 @@ fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- case $LIBOBJS in
- "mkstemp.$ac_objext" | \
- *" mkstemp.$ac_objext" | \
- "mkstemp.$ac_objext "* | \
+ case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
+ ;;
esac
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
-
# Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = yes; then
+ if test "$do64bit" = yes
+then :
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
- { echo "$as_me:$LINENO: WARNING: 64bit mode not supported by gcc" >&5
-echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5
+printf "%s\n" "$as_me: WARNING: 64bit mode not supported by gcc" >&2;}
-else
+else $as_nop
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
@@ -7302,9 +6249,7 @@ else
fi
-
fi
-
;;
Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*)
SHLIB_CFLAGS="-fPIC -fno-common"
@@ -7323,108 +6268,82 @@ fi
case $system in
DragonFly-*|FreeBSD-*)
- if test "${TCL_THREADS}" = "1"; then
+ if test "${TCL_THREADS}" = "1"
+then :
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
fi
-
;;
esac
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
-
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- if test "`uname -m`" = "alpha"; then
+ if test "`uname -m`" = "alpha"
+then :
CFLAGS="$CFLAGS -mieee"
fi
+ if test $do64bit = yes
+then :
- if test $do64bit = yes; then
-
- echo "$as_me:$LINENO: checking if compiler accepts -m64 flag" >&5
-echo $ECHO_N "checking if compiler accepts -m64 flag... $ECHO_C" >&6
-if test "${tcl_cv_cc_m64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -m64 flag" >&5
+printf %s "checking if compiler accepts -m64 flag... " >&6; }
+if test ${tcl_cv_cc_m64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -m64"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cc_m64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_m64=no
+else $as_nop
+ tcl_cv_cc_m64=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_m64" >&5
-echo "${ECHO_T}$tcl_cv_cc_m64" >&6
- if test $tcl_cv_cc_m64 = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_m64" >&5
+printf "%s\n" "$tcl_cv_cc_m64" >&6; }
+ if test $tcl_cv_cc_m64 = yes
+then :
CFLAGS="$CFLAGS -m64"
do64bit_ok=yes
fi
-
fi
-
# The combo of gcc + glibc has a bug related to inlining of
- # functions like strtod(). The -fno-builtin flag should address
+ # functions like strtol()/strtoul(). The -fno-builtin flag should address
# this problem but it does not work. The -fno-inline flag is kind
# of overkill but it works. Disable inlining only when one of the
# files in compat/*.c is being linked in.
- if test x"${USE_COMPAT}" != x; then
+ if test x"${USE_COMPAT}" != x
+then :
CFLAGS="$CFLAGS -fno-inline"
fi
-
;;
Lynx*)
SHLIB_CFLAGS="-fPIC"
@@ -7434,33 +6353,12 @@ fi
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
-
- ;;
- MP-RAS-02*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- MP-RAS-*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- LDFLAGS="$LDFLAGS -Wl,-Bexport"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
;;
OpenBSD-*)
arch=`arch -s`
@@ -7476,24 +6374,19 @@ fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
-
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}'
+ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
- if test "${TCL_THREADS}" = "1"; then
-
- # On OpenBSD: Compile with -pthread
- # Don't link with -lpthread
- LIBS=`echo $LIBS | sed s/-lpthread//`
- CFLAGS="$CFLAGS -pthread"
-
-fi
-
+ # On OpenBSD: Compile with -pthread
+ # Don't link with -lpthread
+ LIBS=`echo $LIBS | sed s/-lpthread//`
+ CFLAGS="$CFLAGS -pthread"
# OpenBSD doesn't do version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
TCL_LIB_VERSIONS_OK=nodots
@@ -7506,21 +6399,16 @@ fi
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
-
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- if test "${TCL_THREADS}" = "1"; then
-
- # The -pthread needs to go in the CFLAGS, not LIBS
- LIBS=`echo $LIBS | sed s/-pthread//`
- CFLAGS="$CFLAGS -pthread"
- LDFLAGS="$LDFLAGS -pthread"
-
-fi
-
+ # The -pthread needs to go in the CFLAGS, not LIBS
+ LIBS=`echo $LIBS | sed s/-pthread//`
+ CFLAGS="$CFLAGS -pthread"
+ LDFLAGS="$LDFLAGS -pthread"
;;
Darwin-*)
CFLAGS_OPTIMIZE="-O2"
@@ -7534,399 +6422,269 @@ fi
CFLAGS="`echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`"
- if test $do64bit = yes; then
+ if test $do64bit = yes
+then :
case `arch` in
ppc)
- echo "$as_me:$LINENO: checking if compiler accepts -arch ppc64 flag" >&5
-echo $ECHO_N "checking if compiler accepts -arch ppc64 flag... $ECHO_C" >&6
-if test "${tcl_cv_cc_arch_ppc64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch ppc64 flag" >&5
+printf %s "checking if compiler accepts -arch ppc64 flag... " >&6; }
+if test ${tcl_cv_cc_arch_ppc64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cc_arch_ppc64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_arch_ppc64=no
+else $as_nop
+ tcl_cv_cc_arch_ppc64=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_ppc64" >&5
-echo "${ECHO_T}$tcl_cv_cc_arch_ppc64" >&6
- if test $tcl_cv_cc_arch_ppc64 = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_ppc64" >&5
+printf "%s\n" "$tcl_cv_cc_arch_ppc64" >&6; }
+ if test $tcl_cv_cc_arch_ppc64 = yes
+then :
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
do64bit_ok=yes
-fi
-;;
+fi;;
i386|x86_64)
- echo "$as_me:$LINENO: checking if compiler accepts -arch x86_64 flag" >&5
-echo $ECHO_N "checking if compiler accepts -arch x86_64 flag... $ECHO_C" >&6
-if test "${tcl_cv_cc_arch_x86_64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch x86_64 flag" >&5
+printf %s "checking if compiler accepts -arch x86_64 flag... " >&6; }
+if test ${tcl_cv_cc_arch_x86_64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch x86_64"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cc_arch_x86_64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_arch_x86_64=no
+else $as_nop
+ tcl_cv_cc_arch_x86_64=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_x86_64" >&5
-echo "${ECHO_T}$tcl_cv_cc_arch_x86_64" >&6
- if test $tcl_cv_cc_arch_x86_64 = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_x86_64" >&5
+printf "%s\n" "$tcl_cv_cc_arch_x86_64" >&6; }
+ if test $tcl_cv_cc_arch_x86_64 = yes
+then :
CFLAGS="$CFLAGS -arch x86_64"
do64bit_ok=yes
-fi
-;;
+fi;;
arm64)
- echo "$as_me:$LINENO: checking if compiler accepts -arch arm64 flag" >&5
-echo $ECHO_N "checking if compiler accepts -arch arm64 flag... $ECHO_C" >&6
-if test "${tcl_cv_cc_arch_arm64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch arm64 flag" >&5
+printf %s "checking if compiler accepts -arch arm64 flag... " >&6; }
+if test ${tcl_cv_cc_arch_arm64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch arm64"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cc_arch_arm64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_arch_arm64=no
+else $as_nop
+ tcl_cv_cc_arch_arm64=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_arm64" >&5
-echo "${ECHO_T}$tcl_cv_cc_arch_arm64" >&6
- if test $tcl_cv_cc_arch_arm64 = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_arm64" >&5
+printf "%s\n" "$tcl_cv_cc_arch_arm64" >&6; }
+ if test $tcl_cv_cc_arch_arm64 = yes
+then :
CFLAGS="$CFLAGS -arch arm64"
do64bit_ok=yes
-fi
-;;
+fi;;
*)
- { echo "$as_me:$LINENO: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5
-echo "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};;
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5
+printf "%s\n" "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};;
esac
-else
+else $as_nop
# Check for combined 32-bit and 64-bit fat build
if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64|arm64) ' \
- && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '; then
+ && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '
+then :
fat_32_64=yes
fi
-
fi
-
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
- echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5
-echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6
-if test "${tcl_cv_ld_single_module+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -single_module flag" >&5
+printf %s "checking if ld accepts -single_module flag... " >&6; }
+if test ${tcl_cv_ld_single_module+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
int i;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_ld_single_module=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_ld_single_module=no
+else $as_nop
+ tcl_cv_ld_single_module=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5
-echo "${ECHO_T}$tcl_cv_ld_single_module" >&6
- if test $tcl_cv_ld_single_module = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_single_module" >&5
+printf "%s\n" "$tcl_cv_ld_single_module" >&6; }
+ if test $tcl_cv_ld_single_module = yes
+then :
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
fi
-
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -headerpad_max_install_names"
- echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5
-echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6
-if test "${tcl_cv_ld_search_paths_first+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5
+printf %s "checking if ld accepts -search_paths_first flag... " >&6; }
+if test ${tcl_cv_ld_search_paths_first+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
int i;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_ld_search_paths_first=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_ld_search_paths_first=no
+else $as_nop
+ tcl_cv_ld_search_paths_first=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5
-echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6
- if test $tcl_cv_ld_search_paths_first = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_search_paths_first" >&5
+printf "%s\n" "$tcl_cv_ld_search_paths_first" >&6; }
+ if test $tcl_cv_ld_search_paths_first = yes
+then :
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
fi
+ if test "$tcl_cv_cc_visibility_hidden" != yes
+then :
- if test "$tcl_cv_cc_visibility_hidden" != yes; then
-
-cat >>confdefs.h <<\_ACEOF
-#define MODULE_SCOPE __private_extern__
-_ACEOF
+printf "%s\n" "#define MODULE_SCOPE __private_extern__" >>confdefs.h
tcl_cv_cc_visibility_hidden=yes
fi
-
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
LD_LIBRARY_PATH_VAR="DYLD_FALLBACK_LIBRARY_PATH"
-cat >>confdefs.h <<\_ACEOF
-#define MAC_OSX_TCL 1
-_ACEOF
+printf "%s\n" "#define MAC_OSX_TCL 1" >>confdefs.h
PLAT_OBJS='${MAC_OSX_OBJS}'
PLAT_SRCS='${MAC_OSX_SRCS}'
- echo "$as_me:$LINENO: checking whether to use CoreFoundation" >&5
-echo $ECHO_N "checking whether to use CoreFoundation... $ECHO_C" >&6
- # Check whether --enable-corefoundation or --disable-corefoundation was given.
-if test "${enable_corefoundation+set}" = set; then
- enableval="$enable_corefoundation"
- tcl_corefoundation=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use CoreFoundation" >&5
+printf %s "checking whether to use CoreFoundation... " >&6; }
+ # Check whether --enable-corefoundation was given.
+if test ${enable_corefoundation+y}
+then :
+ enableval=$enable_corefoundation; tcl_corefoundation=$enableval
+else $as_nop
tcl_corefoundation=yes
-fi;
- echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5
-echo "${ECHO_T}$tcl_corefoundation" >&6
- if test $tcl_corefoundation = yes; then
-
- echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5
-echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6
-if test "${tcl_cv_lib_corefoundation+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_corefoundation" >&5
+printf "%s\n" "$tcl_corefoundation" >&6; }
+ if test $tcl_corefoundation = yes
+then :
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for CoreFoundation.framework" >&5
+printf %s "checking for CoreFoundation.framework... " >&6; }
+if test ${tcl_cv_lib_corefoundation+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_libs=$LIBS
- if test "$fat_32_64" = yes; then
+ if test "$fat_32_64" = yes
+then :
for v in CFLAGS CPPFLAGS LDFLAGS; do
# On Tiger there is no 64-bit CF, so remove 64-bit
@@ -7936,262 +6694,155 @@ else
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"'
done
fi
-
LIBS="$LIBS -framework CoreFoundation"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <CoreFoundation/CoreFoundation.h>
int
-main ()
+main (void)
{
CFBundleRef b = CFBundleGetMainBundle();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_lib_corefoundation=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_lib_corefoundation=no
+else $as_nop
+ tcl_cv_lib_corefoundation=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
- if test "$fat_32_64" = yes; then
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
+ if test "$fat_32_64" = yes
+then :
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done
fi
-
LIBS=$hold_libs
fi
-echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5
-echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6
- if test $tcl_cv_lib_corefoundation = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation" >&5
+printf "%s\n" "$tcl_cv_lib_corefoundation" >&6; }
+ if test $tcl_cv_lib_corefoundation = yes
+then :
LIBS="$LIBS -framework CoreFoundation"
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_COREFOUNDATION 1
-_ACEOF
+printf "%s\n" "#define HAVE_COREFOUNDATION 1" >>confdefs.h
-else
+else $as_nop
tcl_corefoundation=no
fi
+ if test "$fat_32_64" = yes -a $tcl_corefoundation = yes
+then :
- if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then
-
- echo "$as_me:$LINENO: checking for 64-bit CoreFoundation" >&5
-echo $ECHO_N "checking for 64-bit CoreFoundation... $ECHO_C" >&6
-if test "${tcl_cv_lib_corefoundation_64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit CoreFoundation" >&5
+printf %s "checking for 64-bit CoreFoundation... " >&6; }
+if test ${tcl_cv_lib_corefoundation_64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"'
done
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <CoreFoundation/CoreFoundation.h>
int
-main ()
+main (void)
{
CFBundleRef b = CFBundleGetMainBundle();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_lib_corefoundation_64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_lib_corefoundation_64=no
+else $as_nop
+ tcl_cv_lib_corefoundation_64=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done
fi
-echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation_64" >&5
-echo "${ECHO_T}$tcl_cv_lib_corefoundation_64" >&6
- if test $tcl_cv_lib_corefoundation_64 = no; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation_64" >&5
+printf "%s\n" "$tcl_cv_lib_corefoundation_64" >&6; }
+ if test $tcl_cv_lib_corefoundation_64 = no
+then :
-cat >>confdefs.h <<\_ACEOF
-#define NO_COREFOUNDATION_64 1
-_ACEOF
+printf "%s\n" "#define NO_COREFOUNDATION_64 1" >>confdefs.h
LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings"
fi
-
fi
-
fi
-
- ;;
- NEXTSTEP-*)
- SHLIB_CFLAGS=""
- SHLIB_LD='${CC} -nostdlib -r'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadNext.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
;;
OS/390-*)
SHLIB_LD_LIBS=""
CFLAGS_OPTIMIZE="" # Optimizer is buggy
-cat >>confdefs.h <<\_ACEOF
-#define _OE_SOCKETS 1
-_ACEOF
+printf "%s\n" "#define _OE_SOCKETS 1" >>confdefs.h
;;
- OSF1-1.0|OSF1-1.1|OSF1-1.2)
- # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
- SHLIB_CFLAGS=""
- # Hack: make package name same as library name
- SHLIB_LD='ld -R -export :'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadOSF.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- OSF1-1.*)
- # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
- SHLIB_CFLAGS="-fPIC"
- if test "$SHARED_BUILD" = 1; then
- SHLIB_LD="ld -shared"
-else
-
- SHLIB_LD="ld -non_shared"
-
-fi
-
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
- if test "$SHARED_BUILD" = 1; then
+ if test "$SHARED_BUILD" = 1
+then :
SHLIB_LD='${CC} -shared'
-else
+else $as_nop
SHLIB_LD='${CC} -non_shared'
fi
-
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- if test $doRpath = yes; then
+ if test $doRpath = yes
+then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
-
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
CFLAGS="$CFLAGS -mieee"
-else
+else $as_nop
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"
fi
-
# see pthread_intro(3) for pthread support on osf1, k.furukawa
- if test "${TCL_THREADS}" = 1; then
-
- CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
- CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
- LIBS=`echo $LIBS | sed s/-lpthreads//`
- if test "$GCC" = yes; then
+ CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
+ CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
+ LIBS=`echo $LIBS | sed s/-lpthreads//`
+ if test "$GCC" = yes
+then :
- LIBS="$LIBS -lpthread -lmach -lexc"
+ LIBS="$LIBS -lpthread -lmach -lexc"
-else
-
- CFLAGS="$CFLAGS -pthread"
- LDFLAGS="$LDFLAGS -pthread"
-
-fi
+else $as_nop
+ CFLAGS="$CFLAGS -pthread"
+ LDFLAGS="$LDFLAGS -pthread"
fi
-
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
- SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
@@ -8205,18 +6856,18 @@ fi
# Note, dlopen is available only on SCO 3.2.5 and greater. However,
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
SHLIB_CFLAGS="-fPIC -melf"
LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
-else
+else $as_nop
SHLIB_CFLAGS="-Kpic -belf"
LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
fi
-
SHLIB_LD="ld -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
@@ -8225,35 +6876,6 @@ fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
- SINIX*5.4*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- SunOS-4*)
- SHLIB_CFLAGS="-PIC"
- SHLIB_LD="ld"
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
-
- # SunOS can't handle version numbers with dots in them in library
- # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it
- # requires an extra version number at the end of .so file names.
- # So, the library has to have a name like libtcl75.so.1.0
-
- SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}'
- UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
- TCL_LIB_VERSIONS_OK=nodots
- ;;
SunOS-5.[0-6])
# Careful to not let 5.10+ fall into this case
@@ -8261,66 +6883,62 @@ fi
# won't define thread-safe library routines.
-cat >>confdefs.h <<\_ACEOF
-#define _REENTRANT 1
-_ACEOF
+printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define _POSIX_PTHREAD_SEMANTICS 1
-_ACEOF
+printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h
SHLIB_CFLAGS="-KPIC"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
SHLIB_LD='${CC} -shared'
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
-else
+else $as_nop
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
fi
-
;;
SunOS-5*)
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
-cat >>confdefs.h <<\_ACEOF
-#define _REENTRANT 1
-_ACEOF
+printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define _POSIX_PTHREAD_SEMANTICS 1
-_ACEOF
+printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h
SHLIB_CFLAGS="-KPIC"
# Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = yes; then
+ if test "$do64bit" = yes
+then :
arch=`isainfo`
- if test "$arch" = "sparcv9 sparc"; then
+ if test "$arch" = "sparcv9 sparc"
+then :
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
- if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3; then
+ if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3
+then :
- { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5
-echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5
+printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;}
-else
+else $as_nop
do64bit_ok=yes
CFLAGS="$CFLAGS -m64 -mcpu=v9"
@@ -8329,32 +6947,32 @@ else
fi
-
-else
+else $as_nop
do64bit_ok=yes
- if test "$do64bitVIS" = yes; then
+ if test "$do64bitVIS" = yes
+then :
CFLAGS="$CFLAGS -xarch=v9a"
LDFLAGS_ARCH="-xarch=v9a"
-else
+else $as_nop
CFLAGS="$CFLAGS -xarch=v9"
LDFLAGS_ARCH="-xarch=v9"
fi
-
# Solaris 64 uses this as well
#LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64"
fi
+else $as_nop
+ if test "$arch" = "amd64 i386"
+then :
-else
- if test "$arch" = "amd64 i386"; then
-
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
case $system in
SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*)
@@ -8362,11 +6980,11 @@ else
CFLAGS="$CFLAGS -m64"
LDFLAGS="$LDFLAGS -m64";;
*)
- { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5
-echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};;
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
+printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};;
esac
-else
+else $as_nop
do64bit_ok=yes
case $system in
@@ -8380,197 +6998,63 @@ else
fi
-
-else
- { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5
-echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;}
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported for $arch" >&5
+printf "%s\n" "$as_me: WARNING: 64bit mode not supported for $arch" >&2;}
fi
-
fi
-
fi
-
#--------------------------------------------------------------------
# On Solaris 5.x i386 with the sunpro compiler we need to link
# with sunmath to get floating point rounding control
#--------------------------------------------------------------------
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
use_sunmath=no
-else
+else $as_nop
arch=`isainfo`
- echo "$as_me:$LINENO: checking whether to use -lsunmath for fp rounding control" >&5
-echo $ECHO_N "checking whether to use -lsunmath for fp rounding control... $ECHO_C" >&6
- if test "$arch" = "amd64 i386" -o "$arch" = "i386"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use -lsunmath for fp rounding control" >&5
+printf %s "checking whether to use -lsunmath for fp rounding control... " >&6; }
+ if test "$arch" = "amd64 i386" -o "$arch" = "i386"
+then :
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
MATH_LIBS="-lsunmath $MATH_LIBS"
- if test "${ac_cv_header_sunmath_h+set}" = set; then
- echo "$as_me:$LINENO: checking for sunmath.h" >&5
-echo $ECHO_N "checking for sunmath.h... $ECHO_C" >&6
-if test "${ac_cv_header_sunmath_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_sunmath_h" >&5
-echo "${ECHO_T}$ac_cv_header_sunmath_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking sunmath.h usability" >&5
-echo $ECHO_N "checking sunmath.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <sunmath.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking sunmath.h presence" >&5
-echo $ECHO_N "checking sunmath.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <sunmath.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
+ ac_fn_c_check_header_compile "$LINENO" "sunmath.h" "ac_cv_header_sunmath_h" "$ac_includes_default"
+if test "x$ac_cv_header_sunmath_h" = xyes
+then :
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: sunmath.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: sunmath.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: sunmath.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: sunmath.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: sunmath.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: sunmath.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: sunmath.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: sunmath.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: sunmath.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: sunmath.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: sunmath.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: sunmath.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: sunmath.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: sunmath.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: sunmath.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: sunmath.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for sunmath.h" >&5
-echo $ECHO_N "checking for sunmath.h... $ECHO_C" >&6
-if test "${ac_cv_header_sunmath_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_sunmath_h=$ac_header_preproc
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_sunmath_h" >&5
-echo "${ECHO_T}$ac_cv_header_sunmath_h" >&6
-
-fi
-
use_sunmath=yes
-else
+else $as_nop
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
use_sunmath=no
fi
-
fi
-
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
- if test "$GCC" = yes; then
+ if test "$GCC" = yes
+then :
SHLIB_LD='${CC} -shared'
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- if test "$do64bit_ok" = yes; then
+ if test "$do64bit_ok" = yes
+then :
- if test "$arch" = "sparcv9 sparc"; then
+ if test "$arch" = "sparcv9 sparc"
+then :
# We need to specify -static-libgcc or we need to
# add the path to the sparv9 libgcc.
@@ -8580,27 +7064,25 @@ fi
#v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..."
#CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
-else
- if test "$arch" = "amd64 i386"; then
+else $as_nop
+ if test "$arch" = "amd64 i386"
+then :
SHLIB_LD="$SHLIB_LD -m64 -static-libgcc"
fi
-
fi
-
fi
+else $as_nop
-else
-
- if test "$use_sunmath" = yes; then
+ if test "$use_sunmath" = yes
+then :
textmode=textoff
-else
+else $as_nop
textmode=text
fi
-
case $system in
SunOS-5.[1-9][0-9]*|SunOS-5.[7-9])
SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";;
@@ -8611,7 +7093,6 @@ fi
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
fi
-
;;
UNIX_SV* | UnixWare-5*)
SHLIB_CFLAGS="-KPIC"
@@ -8622,116 +7103,90 @@ fi
DL_LIBS="-ldl"
# Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
# that don't grok the -Bexport option. Test that it does.
- echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5
-echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6
-if test "${tcl_cv_ld_Bexport+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ld accepts -Bexport flag" >&5
+printf %s "checking for ld accepts -Bexport flag... " >&6; }
+if test ${tcl_cv_ld_Bexport+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-Bexport"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
int i;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_ld_Bexport=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_ld_Bexport=no
+else $as_nop
+ tcl_cv_ld_Bexport=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_ld_Bexport" >&5
-echo "${ECHO_T}$tcl_cv_ld_Bexport" >&6
- if test $tcl_cv_ld_Bexport = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5
+printf "%s\n" "$tcl_cv_ld_Bexport" >&6; }
+ if test $tcl_cv_ld_Bexport = yes
+then :
LDFLAGS="$LDFLAGS -Wl,-Bexport"
fi
-
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
- if test "$do64bit" = yes -a "$do64bit_ok" = no; then
+ if test "$do64bit" = yes -a "$do64bit_ok" = no
+then :
- { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5
-echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5
+printf "%s\n" "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;}
fi
-
- if test "$do64bit" = yes -a "$do64bit_ok" = yes; then
+ if test "$do64bit" = yes -a "$do64bit_ok" = yes
+then :
-cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_DO64BIT 1
-_ACEOF
+printf "%s\n" "#define TCL_CFG_DO64BIT 1" >>confdefs.h
fi
-
# Step 4: disable dynamic loading if requested via a command-line switch.
- # Check whether --enable-load or --disable-load was given.
-if test "${enable_load+set}" = set; then
- enableval="$enable_load"
- tcl_ok=$enableval
-else
+ # Check whether --enable-load was given.
+if test ${enable_load+y}
+then :
+ enableval=$enable_load; tcl_ok=$enableval
+else $as_nop
tcl_ok=yes
-fi;
- if test "$tcl_ok" = no; then
- DL_OBJS=""
fi
+ if test "$tcl_ok" = no
+then :
+ DL_OBJS=""
+fi
- if test "x$DL_OBJS" != x; then
+ if test "x$DL_OBJS" != x
+then :
BUILD_DLTEST="\$(DLTEST_TARGETS)"
-else
+else $as_nop
- { echo "$as_me:$LINENO: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5
-echo "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5
+printf "%s\n" "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;}
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
@@ -8743,14 +7198,14 @@ echo "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libr
BUILD_DLTEST=""
fi
-
LDFLAGS="$LDFLAGS $LDFLAGS_ARCH"
# If we're running gcc, then change the C flags for compiling shared
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
- if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then
+ if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes
+then :
case $system in
AIX-*) ;;
@@ -8759,6 +7214,7 @@ fi
HP-UX*) ;;
Darwin-*) ;;
IRIX*) ;;
+ Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-*) ;;
SCO_SV-3.2*) ;;
@@ -8766,106 +7222,100 @@ fi
esac
fi
+ if test "$tcl_cv_cc_visibility_hidden" != yes
+then :
- if test "$tcl_cv_cc_visibility_hidden" != yes; then
-
-cat >>confdefs.h <<\_ACEOF
-#define MODULE_SCOPE extern
-_ACEOF
+printf "%s\n" "#define MODULE_SCOPE extern" >>confdefs.h
fi
-
- if test "$SHARED_LIB_SUFFIX" = ""; then
+ if test "$SHARED_LIB_SUFFIX" = ""
+then :
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
fi
-
- if test "$UNSHARED_LIB_SUFFIX" = ""; then
+ if test "$UNSHARED_LIB_SUFFIX" = ""
+then :
UNSHARED_LIB_SUFFIX='${VERSION}.a'
fi
-
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
- if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then
+ if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""
+then :
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
- if test "${SHLIB_SUFFIX}" = ".dll"; then
+ if test "${SHLIB_SUFFIX}" = ".dll"
+then :
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
-else
+else $as_nop
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
fi
-
-else
+else $as_nop
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
- if test "$RANLIB" = ""; then
+ if test "$RANLIB" = ""
+then :
MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
-else
+else $as_nop
MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
fi
-
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
fi
-
# Stub lib does not depend on shared/static configuration
- if test "$RANLIB" = ""; then
+ if test "$RANLIB" = ""
+then :
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
-else
+else $as_nop
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
fi
-
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"'
# Define TCL_LIBS now that we know what DL_LIBS is.
# The trick here is that we don't want to change the value of TCL_LIBS if
# it is already set when tclConfig.sh had been loaded by Tk.
- if test "x${TCL_LIBS}" = x; then
+ if test "x${TCL_LIBS}" = x
+then :
TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"
fi
-
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
- echo "$as_me:$LINENO: checking for cast to union support" >&5
-echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
-if test "${tcl_cv_cast_to_union+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
+printf %s "checking for cast to union support... " >&6; }
+if test ${tcl_cv_cast_to_union+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
union foo { int i; double d; };
@@ -8875,108 +7325,99 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_cast_to_union=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cast_to_union=no
+else $as_nop
+ tcl_cv_cast_to_union=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
-echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
+printf "%s\n" "$tcl_cv_cast_to_union" >&6; }
if test "$tcl_cv_cast_to_union" = "yes"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_CAST_TO_UNION 1
-_ACEOF
+printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto"
- echo "$as_me:$LINENO: checking for working -fno-lto" >&5
-echo $ECHO_N "checking for working -fno-lto... $ECHO_C" >&6
-if test "${ac_cv_nolto+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working -fno-lto" >&5
+printf %s "checking for working -fno-lto... " >&6; }
+if test ${ac_cv_nolto+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_nolto=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_nolto=no
+else $as_nop
+ ac_cv_nolto=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_nolto" >&5
-echo "${ECHO_T}$ac_cv_nolto" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_nolto" >&5
+printf "%s\n" "$ac_cv_nolto" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_nolto" = "yes" ; then
CFLAGS_NOLTO="-fno-lto"
else
CFLAGS_NOLTO=""
fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -finput-charset" >&5
+printf %s "checking if the compiler understands -finput-charset... " >&6; }
+if test ${tcl_cv_cc_input_charset+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main (void)
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ tcl_cv_cc_input_charset=yes
+else $as_nop
+ tcl_cv_cc_input_charset=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ CFLAGS=$hold_cflags
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_input_charset" >&5
+printf "%s\n" "$tcl_cv_cc_input_charset" >&6; }
+ if test $tcl_cv_cc_input_charset = yes; then
+ CFLAGS="$CFLAGS -finput-charset=UTF-8"
+ fi
+
+ ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
+if test "x$ac_cv_header_stdbool_h" = xyes
+then :
+
+printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h
+
+fi
+
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
@@ -9007,9 +7448,7 @@ echo "${ECHO_T}$ac_cv_nolto" >&6
-cat >>confdefs.h <<_ACEOF
-#define TCL_SHLIB_EXT "${SHLIB_SUFFIX}"
-_ACEOF
+printf "%s\n" "#define TCL_SHLIB_EXT \"${SHLIB_SUFFIX}\"" >>confdefs.h
@@ -9021,37 +7460,34 @@ _ACEOF
- echo "$as_me:$LINENO: checking for build with symbols" >&5
-echo $ECHO_N "checking for build with symbols... $ECHO_C" >&6
- # Check whether --enable-symbols or --disable-symbols was given.
-if test "${enable_symbols+set}" = set; then
- enableval="$enable_symbols"
- tcl_ok=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
+printf %s "checking for build with symbols... " >&6; }
+ # Check whether --enable-symbols was given.
+if test ${enable_symbols+y}
+then :
+ enableval=$enable_symbols; tcl_ok=$enableval
+else $as_nop
tcl_ok=no
-fi;
+fi
+
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
-cat >>confdefs.h <<\_ACEOF
-#define NDEBUG 1
-_ACEOF
+printf "%s\n" "#define NDEBUG 1" >>confdefs.h
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
-cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_OPTIMIZED 1
-_ACEOF
+printf "%s\n" "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
if test "$tcl_ok" = "yes"; then
- echo "$as_me:$LINENO: result: yes (standard debugging)" >&5
-echo "${ECHO_T}yes (standard debugging)" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
+printf "%s\n" "yes (standard debugging)" >&6; }
fi
fi
@@ -9059,45 +7495,32 @@ echo "${ECHO_T}yes (standard debugging)" >&6
if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_MEM_DEBUG 1
-_ACEOF
+printf "%s\n" "#define TCL_MEM_DEBUG 1" >>confdefs.h
fi
if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_COMPILE_DEBUG 1
-_ACEOF
+printf "%s\n" "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define TCL_COMPILE_STATS 1
-_ACEOF
+printf "%s\n" "#define TCL_COMPILE_STATS 1" >>confdefs.h
fi
if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
if test "$tcl_ok" = "all"; then
- echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5
-echo "${ECHO_T}enabled symbols mem compile debugging" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
+printf "%s\n" "enabled symbols mem compile debugging" >&6; }
else
- echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5
-echo "${ECHO_T}enabled $tcl_ok debugging" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
+printf "%s\n" "enabled $tcl_ok debugging" >&6; }
fi
fi
-cat >>confdefs.h <<\_ACEOF
-#define TCL_TOMMATH 1
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define MP_PREC 4
-_ACEOF
+printf "%s\n" "#define MP_PREC 4" >>confdefs.h
#--------------------------------------------------------------------
@@ -9105,430 +7528,208 @@ _ACEOF
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for required early compiler flags" >&5
-echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for required early compiler flags" >&5
+printf %s "checking for required early compiler flags... " >&6; }
tcl_flags=""
- if test "${tcl_cv_flag__isoc99_source+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ if test ${tcl_cv_flag__isoc99_source+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
int
-main ()
+main (void)
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_flag__isoc99_source=no
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int
-main ()
+main (void)
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_flag__isoc99_source=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_flag__isoc99_source=no
+else $as_nop
+ tcl_cv_flag__isoc99_source=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define _ISOC99_SOURCE 1
-_ACEOF
+printf "%s\n" "#define _ISOC99_SOURCE 1" >>confdefs.h
tcl_flags="$tcl_flags _ISOC99_SOURCE"
fi
- if test "${tcl_cv_flag__largefile64_source+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ if test ${tcl_cv_flag__largefile64_source+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/stat.h>
int
-main ()
+main (void)
{
struct stat64 buf; int i = stat64("/", &buf);
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_flag__largefile64_source=no
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int
-main ()
+main (void)
{
struct stat64 buf; int i = stat64("/", &buf);
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_flag__largefile64_source=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_flag__largefile64_source=no
+else $as_nop
+ tcl_cv_flag__largefile64_source=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define _LARGEFILE64_SOURCE 1
-_ACEOF
+printf "%s\n" "#define _LARGEFILE64_SOURCE 1" >>confdefs.h
tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
fi
if test "x${tcl_flags}" = "x" ; then
- echo "$as_me:$LINENO: result: none" >&5
-echo "${ECHO_T}none" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5
+printf "%s\n" "none" >&6; }
else
- echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
-echo "${ECHO_T}${tcl_flags}" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${tcl_flags}" >&5
+printf "%s\n" "${tcl_flags}" >&6; }
fi
- echo "$as_me:$LINENO: checking for 64-bit integer type" >&5
-echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6
- if test "${tcl_cv_type_64bit+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 'long' and 'long long' have the same size (64-bit)?" >&5
+printf %s "checking if 'long' and 'long long' have the same size (64-bit)?... " >&6; }
+ if test ${tcl_cv_type_64bit+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
tcl_cv_type_64bit=none
- # See if the compiler knows natively about __int64
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-
-int
-main ()
-{
-__int64 value = (__int64) 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_type_64bit=__int64
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_type_64bit="long long"
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- # See if we should use long anyway Note that we substitute in the
+ # See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
switch (0) {
- case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ;
+ case 1: case (sizeof(long long)==sizeof(long)): ;
}
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_cv_type_64bit=${tcl_type_64bit}
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+if ac_fn_c_try_compile "$LINENO"
+then :
+ tcl_cv_type_64bit="long long"
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "${tcl_cv_type_64bit}" = none ; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_WIDE_INT_IS_LONG 1
-_ACEOF
+printf "%s\n" "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h
- echo "$as_me:$LINENO: result: using long" >&5
-echo "${ECHO_T}using long" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
else
-
-cat >>confdefs.h <<_ACEOF
-#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}
-_ACEOF
-
- echo "$as_me:$LINENO: result: ${tcl_cv_type_64bit}" >&5
-echo "${ECHO_T}${tcl_cv_type_64bit}" >&6
-
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
# Now check for auxiliary declarations
- echo "$as_me:$LINENO: checking for struct dirent64" >&5
-echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6
-if test "${tcl_cv_struct_dirent64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5
+printf %s "checking for struct dirent64... " >&6; }
+if test ${tcl_cv_struct_dirent64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
-main ()
+main (void)
{
struct dirent64 p;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_struct_dirent64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_struct_dirent64=no
+else $as_nop
+ tcl_cv_struct_dirent64=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_struct_dirent64" >&5
-echo "${ECHO_T}$tcl_cv_struct_dirent64" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5
+printf "%s\n" "$tcl_cv_struct_dirent64" >&6; }
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_STRUCT_DIRENT64 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h
fi
- echo "$as_me:$LINENO: checking for DIR64" >&5
-echo $ECHO_N "checking for DIR64... $ECHO_C" >&6
-if test "${tcl_cv_DIR64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5
+printf %s "checking for DIR64... " >&6; }
+if test ${tcl_cv_DIR64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
-main ()
+main (void)
{
struct dirent64 *p; DIR64 d = opendir64(".");
p = readdir64(d); rewinddir64(d); closedir64(d);
@@ -9536,62 +7737,34 @@ struct dirent64 *p; DIR64 d = opendir64(".");
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_DIR64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_DIR64=no
+else $as_nop
+ tcl_cv_DIR64=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_DIR64" >&5
-echo "${ECHO_T}$tcl_cv_DIR64" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5
+printf "%s\n" "$tcl_cv_DIR64" >&6; }
if test "x${tcl_cv_DIR64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_DIR64 1
-_ACEOF
+printf "%s\n" "#define HAVE_DIR64 1" >>confdefs.h
fi
- echo "$as_me:$LINENO: checking for struct stat64" >&5
-echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6
-if test "${tcl_cv_struct_stat64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5
+printf %s "checking for struct stat64... " >&6; }
+if test ${tcl_cv_struct_stat64+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/stat.h>
int
-main ()
+main (void)
{
struct stat64 p;
@@ -9599,165 +7772,47 @@ struct stat64 p;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_struct_stat64=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_struct_stat64=no
+else $as_nop
+ tcl_cv_struct_stat64=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_struct_stat64" >&5
-echo "${ECHO_T}$tcl_cv_struct_stat64" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_stat64" >&5
+printf "%s\n" "$tcl_cv_struct_stat64" >&6; }
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_STRUCT_STAT64 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_STAT64 1" >>confdefs.h
fi
+ ac_fn_c_check_func "$LINENO" "open64" "ac_cv_func_open64"
+if test "x$ac_cv_func_open64" = xyes
+then :
+ printf "%s\n" "#define HAVE_OPEN64 1" >>confdefs.h
-
-for ac_func in open64 lseek64
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
+ac_fn_c_check_func "$LINENO" "lseek64" "ac_cv_func_lseek64"
+if test "x$ac_cv_func_lseek64" = xyes
+then :
+ printf "%s\n" "#define HAVE_LSEEK64 1" >>confdefs.h
fi
-done
- echo "$as_me:$LINENO: checking for off64_t" >&5
-echo $ECHO_N "checking for off64_t... $ECHO_C" >&6
- if test "${tcl_cv_type_off64_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for off64_t" >&5
+printf %s "checking for off64_t... " >&6; }
+ if test ${tcl_cv_type_off64_t+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
int
-main ()
+main (void)
{
off64_t offset;
@@ -9765,51 +7820,26 @@ off64_t offset;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_type_off64_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_type_off64_t=no
+else $as_nop
+ tcl_cv_type_off64_t=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "x${tcl_cv_type_off64_t}" = "xyes" && \
test "x${ac_cv_func_lseek64}" = "xyes" && \
test "x${ac_cv_func_open64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TYPE_OFF64_T 1
-_ACEOF
+printf "%s\n" "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
fi
@@ -9819,1273 +7849,401 @@ echo "${ECHO_T}no" >&6
# Tcl_UniChar strings to memcmp on big-endian systems.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5
-echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6
-if test "${ac_cv_c_bigendian+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- # See if sys/param.h defines the BYTE_ORDER macro.
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5
+printf %s "checking whether byte ordering is bigendian... " >&6; }
+if test ${ac_cv_c_bigendian+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_c_bigendian=unknown
+ # See if we're dealing with a universal compiler.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#ifndef __APPLE_CC__
+ not a universal capable compiler
+ #endif
+ typedef int dummy;
+
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+
+ # Check for potential -arch flags. It is not universal unless
+ # there are at least two -arch flags with different values.
+ ac_arch=
+ ac_prev=
+ for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do
+ if test -n "$ac_prev"; then
+ case $ac_word in
+ i?86 | x86_64 | ppc | ppc64)
+ if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then
+ ac_arch=$ac_word
+ else
+ ac_cv_c_bigendian=universal
+ break
+ fi
+ ;;
+ esac
+ ac_prev=
+ elif test "x$ac_word" = "x-arch"; then
+ ac_prev=arch
+ fi
+ done
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ if test $ac_cv_c_bigendian = unknown; then
+ # See if sys/param.h defines the BYTE_ORDER macro.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
-#include <sys/param.h>
+ #include <sys/param.h>
int
-main ()
+main (void)
{
-#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN
- bogus endian macros
-#endif
+#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \
+ && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \
+ && LITTLE_ENDIAN)
+ bogus endian macros
+ #endif
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
# It does; now see whether it defined to BIG_ENDIAN or not.
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
-#include <sys/param.h>
+ #include <sys/param.h>
int
-main ()
+main (void)
{
#if BYTE_ORDER != BIG_ENDIAN
- not big endian
-#endif
+ not big endian
+ #endif
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_c_bigendian=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_c_bigendian=no
+else $as_nop
+ ac_cv_c_bigendian=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-# It does not; compile a test program.
-if test "$cross_compiling" = yes; then
- # try to guess the endianness by grepping values into an object file
- ac_cv_c_bigendian=unknown
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ fi
+ if test $ac_cv_c_bigendian = unknown; then
+ # See if <limits.h> defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris).
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
-short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };
-void _ascii () { char *s = (char *) ascii_mm; s = (char *) ascii_ii; }
-short ebcdic_ii[] = { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 };
-short ebcdic_mm[] = { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 };
-void _ebcdic () { char *s = (char *) ebcdic_mm; s = (char *) ebcdic_ii; }
+#include <limits.h>
+
int
-main ()
+main (void)
{
- _ascii (); _ebcdic ();
+#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN)
+ bogus endian macros
+ #endif
+
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then
- ac_cv_c_bigendian=yes
-fi
-if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then
- if test "$ac_cv_c_bigendian" = unknown; then
- ac_cv_c_bigendian=no
- else
- # finding both strings is unlikely to happen, but who knows?
- ac_cv_c_bigendian=unknown
- fi
-fi
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-int
-main ()
-{
- /* Are we little or big endian? From Harbison&Steele. */
- union
- {
- long l;
- char c[sizeof (long)];
- } u;
- u.l = 1;
- exit (u.c[sizeof (long) - 1] == 1);
-}
-_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_c_bigendian=no
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-ac_cv_c_bigendian=yes
-fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
-fi
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5
-echo "${ECHO_T}$ac_cv_c_bigendian" >&6
-case $ac_cv_c_bigendian in
- yes)
-
-cat >>confdefs.h <<\_ACEOF
-#define WORDS_BIGENDIAN 1
-_ACEOF
- ;;
- no)
- ;;
- *)
- { { echo "$as_me:$LINENO: error: unknown endianness
-presetting ac_cv_c_bigendian=no (or yes) will help" >&5
-echo "$as_me: error: unknown endianness
-presetting ac_cv_c_bigendian=no (or yes) will help" >&2;}
- { (exit 1); exit 1; }; } ;;
-esac
-
-
-#--------------------------------------------------------------------
-# Supply substitutes for missing POSIX library procedures, or
-# set flags so Tcl uses alternate procedures.
-#--------------------------------------------------------------------
-
-# Check if Posix compliant getcwd exists, if not we'll use getwd.
-
-for ac_func in getcwd
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ # It does; now see whether it defined to _BIG_ENDIAN or not.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
+#include <limits.h>
int
-main ()
+main (void)
{
-return f != $ac_func;
+#ifndef _BIG_ENDIAN
+ not big endian
+ #endif
+
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_c_bigendian=yes
+else $as_nop
+ ac_cv_c_bigendian=no
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
-
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define USEGETWD 1
-_ACEOF
-
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-done
-
-# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
-# define USEGETWD even if the Posix getcwd exists. Add a test ?
-
-
-
-
-
-for ac_func in mkstemp opendir strtol waitpid
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ fi
+ if test $ac_cv_c_bigendian = unknown; then
+ # Compile a test program.
+ if test "$cross_compiling" = yes
+then :
+ # Try to guess by grepping values from an object file.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
+unsigned short int ascii_mm[] =
+ { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
+ unsigned short int ascii_ii[] =
+ { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };
+ int use_ascii (int i) {
+ return ascii_mm[i] + ascii_ii[i];
+ }
+ unsigned short int ebcdic_ii[] =
+ { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 };
+ unsigned short int ebcdic_mm[] =
+ { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 };
+ int use_ebcdic (int i) {
+ return ebcdic_mm[i] + ebcdic_ii[i];
+ }
+ extern int foo;
int
-main ()
+main (void)
{
-return f != $ac_func;
+return use_ascii (foo) == use_ebcdic (foo);
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
-
-else
- case $LIBOBJS in
- "$ac_func.$ac_objext" | \
- *" $ac_func.$ac_objext" | \
- "$ac_func.$ac_objext "* | \
- *" $ac_func.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS $ac_func.$ac_objext" ;;
-esac
-
+if ac_fn_c_try_compile "$LINENO"
+then :
+ if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then
+ ac_cv_c_bigendian=yes
+ fi
+ if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then
+ if test "$ac_cv_c_bigendian" = unknown; then
+ ac_cv_c_bigendian=no
+ else
+ # finding both strings is unlikely to happen, but who knows?
+ ac_cv_c_bigendian=unknown
+ fi
+ fi
fi
-done
-
-
-echo "$as_me:$LINENO: checking for strerror" >&5
-echo $ECHO_N "checking for strerror... $ECHO_C" >&6
-if test "${ac_cv_func_strerror+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Define strerror to an innocuous variant, in case <limits.h> declares strerror.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define strerror innocuous_strerror
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char strerror (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef strerror
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char strerror ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_strerror) || defined (__stub___strerror)
-choke me
-#else
-char (*f) () = strerror;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
+$ac_includes_default
int
-main ()
+main (void)
{
-return f != strerror;
+
+ /* Are we little or big endian? From Harbison&Steele. */
+ union
+ {
+ long int l;
+ char c[sizeof (long int)];
+ } u;
+ u.l = 1;
+ return u.c[sizeof (long int) - 1] == 1;
+
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_strerror=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_strerror=no
+if ac_fn_c_try_run "$LINENO"
+then :
+ ac_cv_c_bigendian=no
+else $as_nop
+ ac_cv_c_bigendian=yes
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_strerror" >&5
-echo "${ECHO_T}$ac_cv_func_strerror" >&6
-if test $ac_cv_func_strerror = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_STRERROR 1
-_ACEOF
+ fi
fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5
+printf "%s\n" "$ac_cv_c_bigendian" >&6; }
+ case $ac_cv_c_bigendian in #(
+ yes)
+ printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h
+;; #(
+ no)
+ ;; #(
+ universal)
-echo "$as_me:$LINENO: checking for getwd" >&5
-echo $ECHO_N "checking for getwd... $ECHO_C" >&6
-if test "${ac_cv_func_getwd+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define getwd to an innocuous variant, in case <limits.h> declares getwd.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define getwd innocuous_getwd
+printf "%s\n" "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char getwd (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ ;; #(
+ *)
+ as_fn_error $? "unknown endianness
+ presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;;
+ esac
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-#undef getwd
+#--------------------------------------------------------------------
+# Supply substitutes for missing POSIX library procedures, or
+# set flags so Tcl uses alternate procedures.
+#--------------------------------------------------------------------
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char getwd ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_getwd) || defined (__stub___getwd)
-choke me
-#else
-char (*f) () = getwd;
-#endif
-#ifdef __cplusplus
-}
-#endif
+# Check if Posix compliant getcwd exists, if not we'll use getwd.
-int
-main ()
-{
-return f != getwd;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_getwd=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ for ac_func in getcwd
+do :
+ ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd"
+if test "x$ac_cv_func_getcwd" = xyes
+then :
+ printf "%s\n" "#define HAVE_GETCWD 1" >>confdefs.h
-ac_cv_func_getwd=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_getwd" >&5
-echo "${ECHO_T}$ac_cv_func_getwd" >&6
-if test $ac_cv_func_getwd = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define NO_GETWD 1
-_ACEOF
+printf "%s\n" "#define USEGETWD 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for wait3" >&5
-echo $ECHO_N "checking for wait3... $ECHO_C" >&6
-if test "${ac_cv_func_wait3+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define wait3 to an innocuous variant, in case <limits.h> declares wait3.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define wait3 innocuous_wait3
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char wait3 (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef wait3
+done
+# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
+# define USEGETWD even if the posix getcwd exists. Add a test ?
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char wait3 ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_wait3) || defined (__stub___wait3)
-choke me
-#else
-char (*f) () = wait3;
-#endif
-#ifdef __cplusplus
-}
-#endif
+ac_fn_c_check_func "$LINENO" "mkstemp" "ac_cv_func_mkstemp"
+if test "x$ac_cv_func_mkstemp" = xyes
+then :
+ printf "%s\n" "#define HAVE_MKSTEMP 1" >>confdefs.h
-int
-main ()
-{
-return f != wait3;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_wait3=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+else $as_nop
+ case " $LIBOBJS " in
+ *" mkstemp.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
+ ;;
+esac
-ac_cv_func_wait3=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_wait3" >&5
-echo "${ECHO_T}$ac_cv_func_wait3" >&6
-if test $ac_cv_func_wait3 = yes; then
- :
-else
+ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir"
+if test "x$ac_cv_func_opendir" = xyes
+then :
+ printf "%s\n" "#define HAVE_OPENDIR 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define NO_WAIT3 1
-_ACEOF
+else $as_nop
+ case " $LIBOBJS " in
+ *" opendir.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS opendir.$ac_objext"
+ ;;
+esac
fi
+ac_fn_c_check_func "$LINENO" "strtol" "ac_cv_func_strtol"
+if test "x$ac_cv_func_strtol" = xyes
+then :
+ printf "%s\n" "#define HAVE_STRTOL 1" >>confdefs.h
-echo "$as_me:$LINENO: checking for fork" >&5
-echo $ECHO_N "checking for fork... $ECHO_C" >&6
-if test "${ac_cv_func_fork+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define fork to an innocuous variant, in case <limits.h> declares fork.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define fork innocuous_fork
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char fork (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+else $as_nop
+ case " $LIBOBJS " in
+ *" strtol.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS strtol.$ac_objext"
+ ;;
+esac
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+fi
+ac_fn_c_check_func "$LINENO" "waitpid" "ac_cv_func_waitpid"
+if test "x$ac_cv_func_waitpid" = xyes
+then :
+ printf "%s\n" "#define HAVE_WAITPID 1" >>confdefs.h
-#undef fork
+else $as_nop
+ case " $LIBOBJS " in
+ *" waitpid.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS waitpid.$ac_objext"
+ ;;
+esac
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char fork ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_fork) || defined (__stub___fork)
-choke me
-#else
-char (*f) () = fork;
-#endif
-#ifdef __cplusplus
-}
-#endif
+fi
-int
-main ()
-{
-return f != fork;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_fork=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_func "$LINENO" "strerror" "ac_cv_func_strerror"
+if test "x$ac_cv_func_strerror" = xyes
+then :
-ac_cv_func_fork=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_fork" >&5
-echo "${ECHO_T}$ac_cv_func_fork" >&6
-if test $ac_cv_func_fork = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define NO_FORK 1
-_ACEOF
+printf "%s\n" "#define NO_STRERROR 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for mknod" >&5
-echo $ECHO_N "checking for mknod... $ECHO_C" >&6
-if test "${ac_cv_func_mknod+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define mknod to an innocuous variant, in case <limits.h> declares mknod.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define mknod innocuous_mknod
+ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd"
+if test "x$ac_cv_func_getwd" = xyes
+then :
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char mknod (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+else $as_nop
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+printf "%s\n" "#define NO_GETWD 1" >>confdefs.h
-#undef mknod
+fi
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char mknod ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_mknod) || defined (__stub___mknod)
-choke me
-#else
-char (*f) () = mknod;
-#endif
-#ifdef __cplusplus
-}
-#endif
+ac_fn_c_check_func "$LINENO" "wait3" "ac_cv_func_wait3"
+if test "x$ac_cv_func_wait3" = xyes
+then :
-int
-main ()
-{
-return f != mknod;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_mknod=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+else $as_nop
-ac_cv_func_mknod=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_mknod" >&5
-echo "${ECHO_T}$ac_cv_func_mknod" >&6
-if test $ac_cv_func_mknod = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_MKNOD 1
-_ACEOF
+printf "%s\n" "#define NO_WAIT3 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for tcdrain" >&5
-echo $ECHO_N "checking for tcdrain... $ECHO_C" >&6
-if test "${ac_cv_func_tcdrain+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define tcdrain to an innocuous variant, in case <limits.h> declares tcdrain.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define tcdrain innocuous_tcdrain
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char tcdrain (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ac_fn_c_check_func "$LINENO" "fork" "ac_cv_func_fork"
+if test "x$ac_cv_func_fork" = xyes
+then :
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+else $as_nop
-#undef tcdrain
+printf "%s\n" "#define NO_FORK 1" >>confdefs.h
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char tcdrain ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_tcdrain) || defined (__stub___tcdrain)
-choke me
-#else
-char (*f) () = tcdrain;
-#endif
-#ifdef __cplusplus
-}
-#endif
+fi
-int
-main ()
-{
-return f != tcdrain;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_tcdrain=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_func "$LINENO" "mknod" "ac_cv_func_mknod"
+if test "x$ac_cv_func_mknod" = xyes
+then :
-ac_cv_func_tcdrain=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_tcdrain" >&5
-echo "${ECHO_T}$ac_cv_func_tcdrain" >&6
-if test $ac_cv_func_tcdrain = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define NO_TCDRAIN 1
-_ACEOF
+printf "%s\n" "#define NO_MKNOD 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for uname" >&5
-echo $ECHO_N "checking for uname... $ECHO_C" >&6
-if test "${ac_cv_func_uname+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define uname to an innocuous variant, in case <limits.h> declares uname.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define uname innocuous_uname
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char uname (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ac_fn_c_check_func "$LINENO" "tcdrain" "ac_cv_func_tcdrain"
+if test "x$ac_cv_func_tcdrain" = xyes
+then :
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+else $as_nop
-#undef uname
+printf "%s\n" "#define NO_TCDRAIN 1" >>confdefs.h
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char uname ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_uname) || defined (__stub___uname)
-choke me
-#else
-char (*f) () = uname;
-#endif
-#ifdef __cplusplus
-}
-#endif
+fi
-int
-main ()
-{
-return f != uname;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_uname=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname"
+if test "x$ac_cv_func_uname" = xyes
+then :
-ac_cv_func_uname=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_uname" >&5
-echo "${ECHO_T}$ac_cv_func_uname" >&6
-if test $ac_cv_func_uname = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define NO_UNAME 1
-_ACEOF
+printf "%s\n" "#define NO_UNAME 1" >>confdefs.h
fi
-if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \
+if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print $1}'`" -lt 7; then
# prior to Darwin 7, realpath is not threadsafe, so don't
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
-echo "$as_me:$LINENO: checking for realpath" >&5
-echo $ECHO_N "checking for realpath... $ECHO_C" >&6
-if test "${ac_cv_func_realpath+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define realpath to an innocuous variant, in case <limits.h> declares realpath.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define realpath innocuous_realpath
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char realpath (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath"
+if test "x$ac_cv_func_realpath" = xyes
+then :
-#undef realpath
+else $as_nop
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char realpath ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_realpath) || defined (__stub___realpath)
-choke me
-#else
-char (*f) () = realpath;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != realpath;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_realpath=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_realpath=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5
-echo "${ECHO_T}$ac_cv_func_realpath" >&6
-if test $ac_cv_func_realpath = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_REALPATH 1
-_ACEOF
+printf "%s\n" "#define NO_REALPATH 1" >>confdefs.h
fi
@@ -11093,505 +8251,101 @@ fi
NEED_FAKE_RFC2553=0
-
-
-
-for ac_func in getnameinfo getaddrinfo freeaddrinfo gai_strerror
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
+ for ac_func in getnameinfo getaddrinfo freeaddrinfo gai_strerror
+do :
+ as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | $as_tr_sh`
+ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
+if eval test \"x\$"$as_ac_var"\" = x"yes"
+then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+#define `printf "%s\n" "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
-else
+else $as_nop
NEED_FAKE_RFC2553=1
fi
-done
-
- echo "$as_me:$LINENO: checking for struct addrinfo" >&5
-echo $ECHO_N "checking for struct addrinfo... $ECHO_C" >&6
-if test "${ac_cv_type_struct_addrinfo+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
+done
+ ac_fn_c_check_type "$LINENO" "struct addrinfo" "ac_cv_type_struct_addrinfo" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
+"
+if test "x$ac_cv_type_struct_addrinfo" = xyes
+then :
-int
-main ()
-{
-if ((struct addrinfo *) 0)
- return 0;
-if (sizeof (struct addrinfo))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_struct_addrinfo=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_struct_addrinfo=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_struct_addrinfo" >&5
-echo "${ECHO_T}$ac_cv_type_struct_addrinfo" >&6
-if test $ac_cv_type_struct_addrinfo = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_STRUCT_ADDRINFO 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_ADDRINFO 1" >>confdefs.h
-else
+else $as_nop
NEED_FAKE_RFC2553=1
fi
-echo "$as_me:$LINENO: checking for struct in6_addr" >&5
-echo $ECHO_N "checking for struct in6_addr... $ECHO_C" >&6
-if test "${ac_cv_type_struct_in6_addr+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-
+ac_fn_c_check_type "$LINENO" "struct in6_addr" "ac_cv_type_struct_in6_addr" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
+"
+if test "x$ac_cv_type_struct_in6_addr" = xyes
+then :
-int
-main ()
-{
-if ((struct in6_addr *) 0)
- return 0;
-if (sizeof (struct in6_addr))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_struct_in6_addr=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_struct_in6_addr=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_struct_in6_addr" >&5
-echo "${ECHO_T}$ac_cv_type_struct_in6_addr" >&6
-if test $ac_cv_type_struct_in6_addr = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_STRUCT_IN6_ADDR 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_IN6_ADDR 1" >>confdefs.h
-else
+else $as_nop
NEED_FAKE_RFC2553=1
fi
-echo "$as_me:$LINENO: checking for struct sockaddr_in6" >&5
-echo $ECHO_N "checking for struct sockaddr_in6... $ECHO_C" >&6
-if test "${ac_cv_type_struct_sockaddr_in6+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-
+ac_fn_c_check_type "$LINENO" "struct sockaddr_in6" "ac_cv_type_struct_sockaddr_in6" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
+"
+if test "x$ac_cv_type_struct_sockaddr_in6" = xyes
+then :
-int
-main ()
-{
-if ((struct sockaddr_in6 *) 0)
- return 0;
-if (sizeof (struct sockaddr_in6))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_struct_sockaddr_in6=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_struct_sockaddr_in6=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_struct_sockaddr_in6" >&5
-echo "${ECHO_T}$ac_cv_type_struct_sockaddr_in6" >&6
-if test $ac_cv_type_struct_sockaddr_in6 = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_STRUCT_SOCKADDR_IN6 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_IN6 1" >>confdefs.h
-else
+else $as_nop
NEED_FAKE_RFC2553=1
fi
-echo "$as_me:$LINENO: checking for struct sockaddr_storage" >&5
-echo $ECHO_N "checking for struct sockaddr_storage... $ECHO_C" >&6
-if test "${ac_cv_type_struct_sockaddr_storage+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-
+ac_fn_c_check_type "$LINENO" "struct sockaddr_storage" "ac_cv_type_struct_sockaddr_storage" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
+"
+if test "x$ac_cv_type_struct_sockaddr_storage" = xyes
+then :
-int
-main ()
-{
-if ((struct sockaddr_storage *) 0)
- return 0;
-if (sizeof (struct sockaddr_storage))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_struct_sockaddr_storage=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_struct_sockaddr_storage=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_struct_sockaddr_storage" >&5
-echo "${ECHO_T}$ac_cv_type_struct_sockaddr_storage" >&6
-if test $ac_cv_type_struct_sockaddr_storage = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_STRUCT_SOCKADDR_STORAGE 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_STORAGE 1" >>confdefs.h
-else
+else $as_nop
NEED_FAKE_RFC2553=1
fi
if test "x$NEED_FAKE_RFC2553" = "x1"; then
-cat >>confdefs.h <<\_ACEOF
-#define NEED_FAKE_RFC2553 1
-_ACEOF
+printf "%s\n" "#define NEED_FAKE_RFC2553 1" >>confdefs.h
- case $LIBOBJS in
- "fake-rfc2553.$ac_objext" | \
- *" fake-rfc2553.$ac_objext" | \
- "fake-rfc2553.$ac_objext "* | \
+ case " $LIBOBJS " in
*" fake-rfc2553.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS fake-rfc2553.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS fake-rfc2553.$ac_objext"
+ ;;
esac
- echo "$as_me:$LINENO: checking for strlcpy" >&5
-echo $ECHO_N "checking for strlcpy... $ECHO_C" >&6
-if test "${ac_cv_func_strlcpy+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define strlcpy to an innocuous variant, in case <limits.h> declares strlcpy.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define strlcpy innocuous_strlcpy
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char strlcpy (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef strlcpy
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char strlcpy ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_strlcpy) || defined (__stub___strlcpy)
-choke me
-#else
-char (*f) () = strlcpy;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != strlcpy;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_strlcpy=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ ac_fn_c_check_func "$LINENO" "strlcpy" "ac_cv_func_strlcpy"
+if test "x$ac_cv_func_strlcpy" = xyes
+then :
-ac_cv_func_strlcpy=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_strlcpy" >&5
-echo "${ECHO_T}$ac_cv_func_strlcpy" >&6
fi
@@ -11600,117 +8354,25 @@ fi
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
-if test "${TCL_THREADS}" = 1; then
- echo "$as_me:$LINENO: checking for getpwuid_r" >&5
-echo $ECHO_N "checking for getpwuid_r... $ECHO_C" >&6
-if test "${ac_cv_func_getpwuid_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define getpwuid_r to an innocuous variant, in case <limits.h> declares getpwuid_r.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define getpwuid_r innocuous_getpwuid_r
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char getpwuid_r (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef getpwuid_r
+ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r"
+if test "x$ac_cv_func_getpwuid_r" = xyes
+then :
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char getpwuid_r ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_getpwuid_r) || defined (__stub___getpwuid_r)
-choke me
-#else
-char (*f) () = getpwuid_r;
-#endif
-#ifdef __cplusplus
-}
-#endif
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 5 args" >&5
+printf %s "checking for getpwuid_r with 5 args... " >&6; }
+if test ${tcl_cv_api_getpwuid_r_5+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
-int
-main ()
-{
-return f != getpwuid_r;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_getpwuid_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_getpwuid_r=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_getpwuid_r" >&5
-echo "${ECHO_T}$ac_cv_func_getpwuid_r" >&6
-if test $ac_cv_func_getpwuid_r = yes; then
-
- echo "$as_me:$LINENO: checking for getpwuid_r with 5 args" >&5
-echo $ECHO_N "checking for getpwuid_r with 5 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getpwuid_r_5+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
-main ()
+main (void)
{
uid_t uid;
@@ -11724,65 +8386,37 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getpwuid_r_5=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getpwuid_r_5=no
+else $as_nop
+ tcl_cv_api_getpwuid_r_5=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getpwuid_r_5" >&5
-echo "${ECHO_T}$tcl_cv_api_getpwuid_r_5" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_5" >&5
+printf "%s\n" "$tcl_cv_api_getpwuid_r_5" >&6; }
tcl_ok=$tcl_cv_api_getpwuid_r_5
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETPWUID_R_5 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETPWUID_R_5 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for getpwuid_r with 4 args" >&5
-echo $ECHO_N "checking for getpwuid_r with 4 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getpwuid_r_4+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 4 args" >&5
+printf %s "checking for getpwuid_r with 4 args... " >&6; }
+if test ${tcl_cv_api_getpwuid_r_4+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
-main ()
+main (void)
{
uid_t uid;
@@ -11796,168 +8430,50 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getpwuid_r_4=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getpwuid_r_4=no
+else $as_nop
+ tcl_cv_api_getpwuid_r_4=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getpwuid_r_4" >&5
-echo "${ECHO_T}$tcl_cv_api_getpwuid_r_4" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_4" >&5
+printf "%s\n" "$tcl_cv_api_getpwuid_r_4" >&6; }
tcl_ok=$tcl_cv_api_getpwuid_r_4
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETPWUID_R_4 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETPWUID_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETPWUID_R 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETPWUID_R 1" >>confdefs.h
fi
fi
- echo "$as_me:$LINENO: checking for getpwnam_r" >&5
-echo $ECHO_N "checking for getpwnam_r... $ECHO_C" >&6
-if test "${ac_cv_func_getpwnam_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define getpwnam_r to an innocuous variant, in case <limits.h> declares getpwnam_r.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define getpwnam_r innocuous_getpwnam_r
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char getpwnam_r (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef getpwnam_r
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char getpwnam_r ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_getpwnam_r) || defined (__stub___getpwnam_r)
-choke me
-#else
-char (*f) () = getpwnam_r;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != getpwnam_r;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_getpwnam_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_func "$LINENO" "getpwnam_r" "ac_cv_func_getpwnam_r"
+if test "x$ac_cv_func_getpwnam_r" = xyes
+then :
-ac_cv_func_getpwnam_r=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_getpwnam_r" >&5
-echo "${ECHO_T}$ac_cv_func_getpwnam_r" >&6
-if test $ac_cv_func_getpwnam_r = yes; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 5 args" >&5
+printf %s "checking for getpwnam_r with 5 args... " >&6; }
+if test ${tcl_cv_api_getpwnam_r_5+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- echo "$as_me:$LINENO: checking for getpwnam_r with 5 args" >&5
-echo $ECHO_N "checking for getpwnam_r with 5 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getpwnam_r_5+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
-main ()
+main (void)
{
char *name;
@@ -11971,65 +8487,37 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getpwnam_r_5=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getpwnam_r_5=no
+else $as_nop
+ tcl_cv_api_getpwnam_r_5=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getpwnam_r_5" >&5
-echo "${ECHO_T}$tcl_cv_api_getpwnam_r_5" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_5" >&5
+printf "%s\n" "$tcl_cv_api_getpwnam_r_5" >&6; }
tcl_ok=$tcl_cv_api_getpwnam_r_5
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETPWNAM_R_5 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETPWNAM_R_5 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for getpwnam_r with 4 args" >&5
-echo $ECHO_N "checking for getpwnam_r with 4 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getpwnam_r_4+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 4 args" >&5
+printf %s "checking for getpwnam_r with 4 args... " >&6; }
+if test ${tcl_cv_api_getpwnam_r_4+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
-main ()
+main (void)
{
char *name;
@@ -12043,168 +8531,50 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getpwnam_r_4=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getpwnam_r_4=no
+else $as_nop
+ tcl_cv_api_getpwnam_r_4=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getpwnam_r_4" >&5
-echo "${ECHO_T}$tcl_cv_api_getpwnam_r_4" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_4" >&5
+printf "%s\n" "$tcl_cv_api_getpwnam_r_4" >&6; }
tcl_ok=$tcl_cv_api_getpwnam_r_4
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETPWNAM_R_4 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETPWNAM_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETPWNAM_R 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETPWNAM_R 1" >>confdefs.h
fi
fi
- echo "$as_me:$LINENO: checking for getgrgid_r" >&5
-echo $ECHO_N "checking for getgrgid_r... $ECHO_C" >&6
-if test "${ac_cv_func_getgrgid_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define getgrgid_r to an innocuous variant, in case <limits.h> declares getgrgid_r.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define getgrgid_r innocuous_getgrgid_r
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char getgrgid_r (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef getgrgid_r
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char getgrgid_r ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_getgrgid_r) || defined (__stub___getgrgid_r)
-choke me
-#else
-char (*f) () = getgrgid_r;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != getgrgid_r;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_getgrgid_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_getgrgid_r=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_getgrgid_r" >&5
-echo "${ECHO_T}$ac_cv_func_getgrgid_r" >&6
-if test $ac_cv_func_getgrgid_r = yes; then
+ac_fn_c_check_func "$LINENO" "getgrgid_r" "ac_cv_func_getgrgid_r"
+if test "x$ac_cv_func_getgrgid_r" = xyes
+then :
- echo "$as_me:$LINENO: checking for getgrgid_r with 5 args" >&5
-echo $ECHO_N "checking for getgrgid_r with 5 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getgrgid_r_5+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 5 args" >&5
+printf %s "checking for getgrgid_r with 5 args... " >&6; }
+if test ${tcl_cv_api_getgrgid_r_5+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
-main ()
+main (void)
{
gid_t gid;
@@ -12218,65 +8588,37 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getgrgid_r_5=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getgrgid_r_5=no
+else $as_nop
+ tcl_cv_api_getgrgid_r_5=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getgrgid_r_5" >&5
-echo "${ECHO_T}$tcl_cv_api_getgrgid_r_5" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_5" >&5
+printf "%s\n" "$tcl_cv_api_getgrgid_r_5" >&6; }
tcl_ok=$tcl_cv_api_getgrgid_r_5
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETGRGID_R_5 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETGRGID_R_5 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for getgrgid_r with 4 args" >&5
-echo $ECHO_N "checking for getgrgid_r with 4 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getgrgid_r_4+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 4 args" >&5
+printf %s "checking for getgrgid_r with 4 args... " >&6; }
+if test ${tcl_cv_api_getgrgid_r_4+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
-main ()
+main (void)
{
gid_t gid;
@@ -12290,168 +8632,50 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getgrgid_r_4=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getgrgid_r_4=no
+else $as_nop
+ tcl_cv_api_getgrgid_r_4=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getgrgid_r_4" >&5
-echo "${ECHO_T}$tcl_cv_api_getgrgid_r_4" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_4" >&5
+printf "%s\n" "$tcl_cv_api_getgrgid_r_4" >&6; }
tcl_ok=$tcl_cv_api_getgrgid_r_4
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETGRGID_R_4 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETGRGID_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETGRGID_R 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETGRGID_R 1" >>confdefs.h
fi
fi
- echo "$as_me:$LINENO: checking for getgrnam_r" >&5
-echo $ECHO_N "checking for getgrnam_r... $ECHO_C" >&6
-if test "${ac_cv_func_getgrnam_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define getgrnam_r to an innocuous variant, in case <limits.h> declares getgrnam_r.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define getgrnam_r innocuous_getgrnam_r
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char getgrnam_r (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef getgrnam_r
+ac_fn_c_check_func "$LINENO" "getgrnam_r" "ac_cv_func_getgrnam_r"
+if test "x$ac_cv_func_getgrnam_r" = xyes
+then :
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char getgrnam_r ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_getgrnam_r) || defined (__stub___getgrnam_r)
-choke me
-#else
-char (*f) () = getgrnam_r;
-#endif
-#ifdef __cplusplus
-}
-#endif
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 5 args" >&5
+printf %s "checking for getgrnam_r with 5 args... " >&6; }
+if test ${tcl_cv_api_getgrnam_r_5+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
-int
-main ()
-{
-return f != getgrnam_r;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_getgrnam_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_getgrnam_r=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_getgrnam_r" >&5
-echo "${ECHO_T}$ac_cv_func_getgrnam_r" >&6
-if test $ac_cv_func_getgrnam_r = yes; then
-
- echo "$as_me:$LINENO: checking for getgrnam_r with 5 args" >&5
-echo $ECHO_N "checking for getgrnam_r with 5 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getgrnam_r_5+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
-main ()
+main (void)
{
char *name;
@@ -12465,65 +8689,37 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getgrnam_r_5=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getgrnam_r_5=no
+else $as_nop
+ tcl_cv_api_getgrnam_r_5=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getgrnam_r_5" >&5
-echo "${ECHO_T}$tcl_cv_api_getgrnam_r_5" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_5" >&5
+printf "%s\n" "$tcl_cv_api_getgrnam_r_5" >&6; }
tcl_ok=$tcl_cv_api_getgrnam_r_5
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETGRNAM_R_5 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETGRNAM_R_5 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for getgrnam_r with 4 args" >&5
-echo $ECHO_N "checking for getgrnam_r with 4 args... $ECHO_C" >&6
-if test "${tcl_cv_api_getgrnam_r_4+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 4 args" >&5
+printf %s "checking for getgrnam_r with 4 args... " >&6; }
+if test ${tcl_cv_api_getgrnam_r_4+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
-main ()
+main (void)
{
char *name;
@@ -12537,279 +8733,96 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_getgrnam_r_4=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_getgrnam_r_4=no
+else $as_nop
+ tcl_cv_api_getgrnam_r_4=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_getgrnam_r_4" >&5
-echo "${ECHO_T}$tcl_cv_api_getgrnam_r_4" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_4" >&5
+printf "%s\n" "$tcl_cv_api_getgrnam_r_4" >&6; }
tcl_ok=$tcl_cv_api_getgrnam_r_4
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETGRNAM_R_4 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETGRNAM_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETGRNAM_R 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETGRNAM_R 1" >>confdefs.h
fi
fi
- if test "`uname -s`" = "Darwin" && \
- test "`uname -r | awk -F. '{print $1}'`" -gt 5; then
- # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
- # are actually MT-safe as they always return pointers
- # from TSD instead of static storage.
+if test "`uname -s`" = "Darwin" && \
+ test "`uname -r | awk -F. '{print $1}'`" -gt 5; then
+ # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
+ # are actually MT-safe as they always return pointers
+ # from TSD instead of static storage.
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_MTSAFE_GETHOSTBYNAME 1
-_ACEOF
+printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_MTSAFE_GETHOSTBYADDR 1
-_ACEOF
+printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
- elif test "`uname -s`" = "HP-UX" && \
- test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
- # Starting with HPUX 11.00 (we believe), gethostbyX
- # are actually MT-safe as they always return pointers
- # from TSD instead of static storage.
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_MTSAFE_GETHOSTBYNAME 1
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_MTSAFE_GETHOSTBYADDR 1
-_ACEOF
+elif test "`uname -s`" = "HP-UX" && \
+ test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
+ # Starting with HPUX 11.00 (we believe), gethostbyX
+ # are actually MT-safe as they always return pointers
+ # from TSD instead of static storage.
+printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
- else
- # Avoids picking hidden internal symbol from libc
- echo "$as_me:$LINENO: checking whether gethostbyname_r is declared" >&5
-echo $ECHO_N "checking whether gethostbyname_r is declared... $ECHO_C" >&6
-if test "${ac_cv_have_decl_gethostbyname_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <netdb.h>
+printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
-int
-main ()
-{
-#ifndef gethostbyname_r
- char *p = (char *) gethostbyname_r;
-#endif
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_have_decl_gethostbyname_r=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_have_decl_gethostbyname_r=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_have_decl_gethostbyname_r" >&5
-echo "${ECHO_T}$ac_cv_have_decl_gethostbyname_r" >&6
-if test $ac_cv_have_decl_gethostbyname_r = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_DECL_GETHOSTBYNAME_R 1
-_ACEOF
+ # Avoids picking hidden internal symbol from libc
+ ac_fn_check_decl "$LINENO" "gethostbyname_r" "ac_cv_have_decl_gethostbyname_r" "#include <netdb.h>
+" "$ac_c_undeclared_builtin_options" "CFLAGS"
+if test "x$ac_cv_have_decl_gethostbyname_r" = xyes
+then :
+ ac_have_decl=1
+else $as_nop
+ ac_have_decl=0
+fi
+printf "%s\n" "#define HAVE_DECL_GETHOSTBYNAME_R $ac_have_decl" >>confdefs.h
+if test $ac_have_decl = 1
+then :
tcl_cv_api_gethostbyname_r=yes
-else
- cat >>confdefs.h <<_ACEOF
-#define HAVE_DECL_GETHOSTBYNAME_R 0
-_ACEOF
-
-tcl_cv_api_gethostbyname_r=no
+else $as_nop
+ tcl_cv_api_gethostbyname_r=no
fi
-
if test "$tcl_cv_api_gethostbyname_r" = yes; then
- echo "$as_me:$LINENO: checking for gethostbyname_r" >&5
-echo $ECHO_N "checking for gethostbyname_r... $ECHO_C" >&6
-if test "${ac_cv_func_gethostbyname_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define gethostbyname_r to an innocuous variant, in case <limits.h> declares gethostbyname_r.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define gethostbyname_r innocuous_gethostbyname_r
+ ac_fn_c_check_func "$LINENO" "gethostbyname_r" "ac_cv_func_gethostbyname_r"
+if test "x$ac_cv_func_gethostbyname_r" = xyes
+then :
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char gethostbyname_r (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 6 args" >&5
+printf %s "checking for gethostbyname_r with 6 args... " >&6; }
+if test ${tcl_cv_api_gethostbyname_r_6+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef gethostbyname_r
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gethostbyname_r ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_gethostbyname_r) || defined (__stub___gethostbyname_r)
-choke me
-#else
-char (*f) () = gethostbyname_r;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != gethostbyname_r;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_gethostbyname_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_gethostbyname_r=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname_r" >&5
-echo "${ECHO_T}$ac_cv_func_gethostbyname_r" >&6
-if test $ac_cv_func_gethostbyname_r = yes; then
-
- echo "$as_me:$LINENO: checking for gethostbyname_r with 6 args" >&5
-echo $ECHO_N "checking for gethostbyname_r with 6 args... $ECHO_C" >&6
-if test "${tcl_cv_api_gethostbyname_r_6+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
-main ()
+main (void)
{
char *name;
@@ -12824,64 +8837,36 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_gethostbyname_r_6=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_gethostbyname_r_6=no
+else $as_nop
+ tcl_cv_api_gethostbyname_r_6=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyname_r_6" >&5
-echo "${ECHO_T}$tcl_cv_api_gethostbyname_r_6" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_6" >&5
+printf "%s\n" "$tcl_cv_api_gethostbyname_r_6" >&6; }
tcl_ok=$tcl_cv_api_gethostbyname_r_6
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYNAME_R_6 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_6 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for gethostbyname_r with 5 args" >&5
-echo $ECHO_N "checking for gethostbyname_r with 5 args... $ECHO_C" >&6
-if test "${tcl_cv_api_gethostbyname_r_5+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 5 args" >&5
+printf %s "checking for gethostbyname_r with 5 args... " >&6; }
+if test ${tcl_cv_api_gethostbyname_r_5+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
-main ()
+main (void)
{
char *name;
@@ -12896,64 +8881,36 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_gethostbyname_r_5=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_gethostbyname_r_5=no
+else $as_nop
+ tcl_cv_api_gethostbyname_r_5=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyname_r_5" >&5
-echo "${ECHO_T}$tcl_cv_api_gethostbyname_r_5" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_5" >&5
+printf "%s\n" "$tcl_cv_api_gethostbyname_r_5" >&6; }
tcl_ok=$tcl_cv_api_gethostbyname_r_5
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYNAME_R_5 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_5 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for gethostbyname_r with 3 args" >&5
-echo $ECHO_N "checking for gethostbyname_r with 3 args... $ECHO_C" >&6
-if test "${tcl_cv_api_gethostbyname_r_3+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 3 args" >&5
+printf %s "checking for gethostbyname_r with 3 args... " >&6; }
+if test ${tcl_cv_api_gethostbyname_r_3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
-main ()
+main (void)
{
char *name;
@@ -12966,54 +8923,27 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_gethostbyname_r_3=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_gethostbyname_r_3=no
+else $as_nop
+ tcl_cv_api_gethostbyname_r_3=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyname_r_3" >&5
-echo "${ECHO_T}$tcl_cv_api_gethostbyname_r_3" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_3" >&5
+printf "%s\n" "$tcl_cv_api_gethostbyname_r_3" >&6; }
tcl_ok=$tcl_cv_api_gethostbyname_r_3
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYNAME_R_3 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_3 1" >>confdefs.h
fi
fi
fi
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYNAME_R 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
@@ -13023,192 +8953,44 @@ fi
# Avoids picking hidden internal symbol from libc
- echo "$as_me:$LINENO: checking whether gethostbyaddr_r is declared" >&5
-echo $ECHO_N "checking whether gethostbyaddr_r is declared... $ECHO_C" >&6
-if test "${ac_cv_have_decl_gethostbyaddr_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <netdb.h>
-
-int
-main ()
-{
-#ifndef gethostbyaddr_r
- char *p = (char *) gethostbyaddr_r;
-#endif
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_have_decl_gethostbyaddr_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_have_decl_gethostbyaddr_r=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_have_decl_gethostbyaddr_r" >&5
-echo "${ECHO_T}$ac_cv_have_decl_gethostbyaddr_r" >&6
-if test $ac_cv_have_decl_gethostbyaddr_r = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_DECL_GETHOSTBYADDR_R 1
-_ACEOF
-
+ ac_fn_check_decl "$LINENO" "gethostbyaddr_r" "ac_cv_have_decl_gethostbyaddr_r" "#include <netdb.h>
+" "$ac_c_undeclared_builtin_options" "CFLAGS"
+if test "x$ac_cv_have_decl_gethostbyaddr_r" = xyes
+then :
+ ac_have_decl=1
+else $as_nop
+ ac_have_decl=0
+fi
+printf "%s\n" "#define HAVE_DECL_GETHOSTBYADDR_R $ac_have_decl" >>confdefs.h
+if test $ac_have_decl = 1
+then :
tcl_cv_api_gethostbyaddr_r=yes
-else
- cat >>confdefs.h <<_ACEOF
-#define HAVE_DECL_GETHOSTBYADDR_R 0
-_ACEOF
-
-tcl_cv_api_gethostbyaddr_r=no
+else $as_nop
+ tcl_cv_api_gethostbyaddr_r=no
fi
-
if test "$tcl_cv_api_gethostbyaddr_r" = yes; then
- echo "$as_me:$LINENO: checking for gethostbyaddr_r" >&5
-echo $ECHO_N "checking for gethostbyaddr_r... $ECHO_C" >&6
-if test "${ac_cv_func_gethostbyaddr_r+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define gethostbyaddr_r to an innocuous variant, in case <limits.h> declares gethostbyaddr_r.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define gethostbyaddr_r innocuous_gethostbyaddr_r
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char gethostbyaddr_r (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ ac_fn_c_check_func "$LINENO" "gethostbyaddr_r" "ac_cv_func_gethostbyaddr_r"
+if test "x$ac_cv_func_gethostbyaddr_r" = xyes
+then :
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef gethostbyaddr_r
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gethostbyaddr_r ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_gethostbyaddr_r) || defined (__stub___gethostbyaddr_r)
-choke me
-#else
-char (*f) () = gethostbyaddr_r;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != gethostbyaddr_r;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_gethostbyaddr_r=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_gethostbyaddr_r=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyaddr_r" >&5
-echo "${ECHO_T}$ac_cv_func_gethostbyaddr_r" >&6
-if test $ac_cv_func_gethostbyaddr_r = yes; then
-
- echo "$as_me:$LINENO: checking for gethostbyaddr_r with 7 args" >&5
-echo $ECHO_N "checking for gethostbyaddr_r with 7 args... $ECHO_C" >&6
-if test "${tcl_cv_api_gethostbyaddr_r_7+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 7 args" >&5
+printf %s "checking for gethostbyaddr_r with 7 args... " >&6; }
+if test ${tcl_cv_api_gethostbyaddr_r_7+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
-main ()
+main (void)
{
char *addr;
@@ -13226,64 +9008,36 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_gethostbyaddr_r_7=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_gethostbyaddr_r_7=no
+else $as_nop
+ tcl_cv_api_gethostbyaddr_r_7=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyaddr_r_7" >&5
-echo "${ECHO_T}$tcl_cv_api_gethostbyaddr_r_7" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_7" >&5
+printf "%s\n" "$tcl_cv_api_gethostbyaddr_r_7" >&6; }
tcl_ok=$tcl_cv_api_gethostbyaddr_r_7
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYADDR_R_7 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYADDR_R_7 1" >>confdefs.h
else
- echo "$as_me:$LINENO: checking for gethostbyaddr_r with 8 args" >&5
-echo $ECHO_N "checking for gethostbyaddr_r with 8 args... $ECHO_C" >&6
-if test "${tcl_cv_api_gethostbyaddr_r_8+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 8 args" >&5
+printf %s "checking for gethostbyaddr_r with 8 args... " >&6; }
+if test ${tcl_cv_api_gethostbyaddr_r_8+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
-main ()
+main (void)
{
char *addr;
@@ -13301,53 +9055,26 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_api_gethostbyaddr_r_8=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_gethostbyaddr_r_8=no
+else $as_nop
+ tcl_cv_api_gethostbyaddr_r_8=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_gethostbyaddr_r_8" >&5
-echo "${ECHO_T}$tcl_cv_api_gethostbyaddr_r_8" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_8" >&5
+printf "%s\n" "$tcl_cv_api_gethostbyaddr_r_8" >&6; }
tcl_ok=$tcl_cv_api_gethostbyaddr_r_8
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYADDR_R_8 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYADDR_R_8 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_GETHOSTBYADDR_R 1
-_ACEOF
+printf "%s\n" "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
@@ -13355,7 +9082,6 @@ fi
fi
- fi
fi
#---------------------------------------------------------------------------
@@ -13367,456 +9093,27 @@ fi
# sys/modem.h is needed on HP-UX.
#---------------------------------------------------------------------------
+ac_fn_c_check_header_compile "$LINENO" "termios.h" "ac_cv_header_termios_h" "$ac_includes_default"
+if test "x$ac_cv_header_termios_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_TERMIOS_H 1" >>confdefs.h
-for ac_header in termios.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-
-done
-
-
-for ac_header in sys/ioctl.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-
-done
-
-
-for ac_header in sys/modem.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
+ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_ioctl_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+ac_fn_c_check_header_compile "$LINENO" "sys/modem.h" "ac_cv_header_sys_modem_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_modem_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_MODEM_H 1" >>confdefs.h
fi
-done
-
#--------------------------------------------------------------------
# Include sys/select.h if it exists and if it supplies things
@@ -13828,552 +9125,279 @@ done
# special flag.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5
-echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6
-if test "${tcl_cv_type_fd_set+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fd_set in sys/types" >&5
+printf %s "checking for fd_set in sys/types... " >&6; }
+if test ${tcl_cv_type_fd_set+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
int
-main ()
+main (void)
{
fd_set readMask, writeMask;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_type_fd_set=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_type_fd_set=no
+else $as_nop
+ tcl_cv_type_fd_set=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5
-echo "${ECHO_T}$tcl_cv_type_fd_set" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_fd_set" >&5
+printf "%s\n" "$tcl_cv_type_fd_set" >&6; }
tcl_ok=$tcl_cv_type_fd_set
if test $tcl_ok = no; then
- echo "$as_me:$LINENO: checking for fd_mask in sys/select" >&5
-echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6
-if test "${tcl_cv_grep_fd_mask+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fd_mask in sys/select" >&5
+printf %s "checking for fd_mask in sys/select... " >&6; }
+if test ${tcl_cv_grep_fd_mask+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/select.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "fd_mask" >/dev/null 2>&1; then
+ $EGREP "fd_mask" >/dev/null 2>&1
+then :
tcl_cv_grep_fd_mask=present
-else
+else $as_nop
tcl_cv_grep_fd_mask=missing
fi
-rm -f conftest*
+rm -rf conftest*
fi
-echo "$as_me:$LINENO: result: $tcl_cv_grep_fd_mask" >&5
-echo "${ECHO_T}$tcl_cv_grep_fd_mask" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_fd_mask" >&5
+printf "%s\n" "$tcl_cv_grep_fd_mask" >&6; }
if test $tcl_cv_grep_fd_mask = present; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_SYS_SELECT_H 1
-_ACEOF
+printf "%s\n" "#define HAVE_SYS_SELECT_H 1" >>confdefs.h
tcl_ok=yes
fi
fi
if test $tcl_ok = no; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_FD_SET 1
-_ACEOF
+printf "%s\n" "#define NO_FD_SET 1" >>confdefs.h
fi
-#------------------------------------------------------------------------------
-# Find out all about time handling differences.
-#------------------------------------------------------------------------------
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pselect" >&5
+printf %s "checking for pselect... " >&6; }
+if test ${tcl_cv_func_pselect+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
-
-
-for ac_header in sys/time.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
+#include <sys/types.h>
+int
+main (void)
+{
+void *func = pselect;
+ ;
+ return 0;
+}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
+if ac_fn_c_try_compile "$LINENO"
+then :
+ tcl_cv_func_pselect=yes
+else $as_nop
+ tcl_cv_func_pselect=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_func_pselect" >&5
+printf "%s\n" "$tcl_cv_func_pselect" >&6; }
+tcl_ok=$tcl_cv_func_pselect
+if test $tcl_ok = yes; then
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
+printf "%s\n" "#define HAVE_PSELECT 1" >>confdefs.h
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+#------------------------------------------------------------------------
+# Options for the notifier. Checks for epoll(7) on Linux, and
+# kqueue(2) on {DragonFly,Free,Net,Open}BSD
+#------------------------------------------------------------------------
-fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for advanced notifier support" >&5
+printf %s "checking for advanced notifier support... " >&6; }
+case x`uname -s` in
+ xLinux)
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: epoll(7)" >&5
+printf "%s\n" "epoll(7)" >&6; }
+ for ac_header in sys/epoll.h
+do :
+ ac_fn_c_check_header_compile "$LINENO" "sys/epoll.h" "ac_cv_header_sys_epoll_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_epoll_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_EPOLL_H 1" >>confdefs.h
-done
+printf "%s\n" "#define NOTIFIER_EPOLL 1" >>confdefs.h
- echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5
-echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6
-if test "${ac_cv_header_time+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <sys/types.h>
-#include <sys/time.h>
-#include <time.h>
+fi
-int
-main ()
-{
-if ((struct tm *) 0)
-return 0;
- ;
- return 0;
-}
+done
+ for ac_header in sys/eventfd.h
+do :
+ ac_fn_c_check_header_compile "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_eventfd_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_EVENTFD_H 1" >>confdefs.h
+
+printf "%s\n" "#define HAVE_EVENTFD 1" >>confdefs.h
+
+fi
+
+done;;
+ xDragonFlyBSD|xFreeBSD|xNetBSD|xOpenBSD)
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: kqueue(2)" >&5
+printf "%s\n" "kqueue(2)" >&6; }
+ # Messy because we want to check if *all* the headers are present, and not
+ # just *any*
+ tcl_kqueue_headers=x
+ for ac_header in sys/types.h sys/event.h sys/time.h
+do :
+ as_ac_Header=`printf "%s\n" "ac_cv_header_$ac_header" | $as_tr_sh`
+ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default"
+if eval test \"x\$"$as_ac_Header"\" = x"yes"
+then :
+ cat >>confdefs.h <<_ACEOF
+#define `printf "%s\n" "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_header_time=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_header_time=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+ tcl_kqueue_headers=${tcl_kqueue_headers}y
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5
-echo "${ECHO_T}$ac_cv_header_time" >&6
-if test $ac_cv_header_time = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define TIME_WITH_SYS_TIME 1
-_ACEOF
+done
+ if test $tcl_kqueue_headers = xyyy
+then :
-fi
+printf "%s\n" "#define NOTIFIER_KQUEUE 1" >>confdefs.h
+fi;;
+ xDarwin)
+ # Assume that we've got CoreFoundation present (checked elsewhere because
+ # of wider impact).
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: OSX" >&5
+printf "%s\n" "OSX" >&6; };;
+ *)
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5
+printf "%s\n" "none" >&6; };;
+esac
+#------------------------------------------------------------------------------
+# Find out all about time handling differences.
+#------------------------------------------------------------------------------
-for ac_func in gmtime_r localtime_r mktime
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ ac_fn_c_check_header_compile "$LINENO" "sys/time.h" "ac_cv_header_sys_time_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_time_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_TIME_H 1" >>confdefs.h
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+fi
-#undef $ac_func
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ ac_fn_c_check_func "$LINENO" "gmtime_r" "ac_cv_func_gmtime_r"
+if test "x$ac_cv_func_gmtime_r" = xyes
+then :
+ printf "%s\n" "#define HAVE_GMTIME_R 1" >>confdefs.h
-eval "$as_ac_var=no"
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+ac_fn_c_check_func "$LINENO" "localtime_r" "ac_cv_func_localtime_r"
+if test "x$ac_cv_func_localtime_r" = xyes
+then :
+ printf "%s\n" "#define HAVE_LOCALTIME_R 1" >>confdefs.h
+
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
+ac_fn_c_check_func "$LINENO" "mktime" "ac_cv_func_mktime"
+if test "x$ac_cv_func_mktime" = xyes
+then :
+ printf "%s\n" "#define HAVE_MKTIME 1" >>confdefs.h
fi
-done
- echo "$as_me:$LINENO: checking tm_tzadj in struct tm" >&5
-echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6
-if test "${tcl_cv_member_tm_tzadj+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking tm_tzadj in struct tm" >&5
+printf %s "checking tm_tzadj in struct tm... " >&6; }
+if test ${tcl_cv_member_tm_tzadj+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
-main ()
+main (void)
{
struct tm tm; (void)tm.tm_tzadj;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_member_tm_tzadj=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_member_tm_tzadj=no
+else $as_nop
+ tcl_cv_member_tm_tzadj=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5
-echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_tzadj" >&5
+printf "%s\n" "$tcl_cv_member_tm_tzadj" >&6; }
if test $tcl_cv_member_tm_tzadj = yes ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TM_TZADJ 1
-_ACEOF
+printf "%s\n" "#define HAVE_TM_TZADJ 1" >>confdefs.h
fi
- echo "$as_me:$LINENO: checking tm_gmtoff in struct tm" >&5
-echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6
-if test "${tcl_cv_member_tm_gmtoff+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking tm_gmtoff in struct tm" >&5
+printf %s "checking tm_gmtoff in struct tm... " >&6; }
+if test ${tcl_cv_member_tm_gmtoff+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
-main ()
+main (void)
{
struct tm tm; (void)tm.tm_gmtoff;
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_member_tm_gmtoff=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_member_tm_gmtoff=no
+else $as_nop
+ tcl_cv_member_tm_gmtoff=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5
-echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_gmtoff" >&5
+printf "%s\n" "$tcl_cv_member_tm_gmtoff" >&6; }
if test $tcl_cv_member_tm_gmtoff = yes ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TM_GMTOFF 1
-_ACEOF
+printf "%s\n" "#define HAVE_TM_GMTOFF 1" >>confdefs.h
fi
@@ -14381,22 +9405,19 @@ _ACEOF
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
- echo "$as_me:$LINENO: checking long timezone variable" >&5
-echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6
-if test "${tcl_cv_timezone_long+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking long timezone variable" >&5
+printf %s "checking long timezone variable... " >&6; }
+if test ${tcl_cv_timezone_long+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
#include <stdlib.h>
int
-main ()
+main (void)
{
extern long timezone;
timezone += 1;
@@ -14405,65 +9426,37 @@ extern long timezone;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_timezone_long=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_timezone_long=no
+else $as_nop
+ tcl_cv_timezone_long=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5
-echo "${ECHO_T}$tcl_cv_timezone_long" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_long" >&5
+printf "%s\n" "$tcl_cv_timezone_long" >&6; }
if test $tcl_cv_timezone_long = yes ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TIMEZONE_VAR 1
-_ACEOF
+printf "%s\n" "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h
else
#
# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
#
- echo "$as_me:$LINENO: checking time_t timezone variable" >&5
-echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6
-if test "${tcl_cv_timezone_time+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking time_t timezone variable" >&5
+printf %s "checking time_t timezone variable... " >&6; }
+if test ${tcl_cv_timezone_time+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
#include <stdlib.h>
int
-main ()
+main (void)
{
extern time_t timezone;
timezone += 1;
@@ -14472,44 +9465,19 @@ extern time_t timezone;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_timezone_time=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_timezone_time=no
+else $as_nop
+ tcl_cv_timezone_time=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5
-echo "${ECHO_T}$tcl_cv_timezone_time" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_time" >&5
+printf "%s\n" "$tcl_cv_timezone_time" >&6; }
if test $tcl_cv_timezone_time = yes ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TIMEZONE_VAR 1
-_ACEOF
+printf "%s\n" "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h
fi
fi
@@ -14522,388 +9490,40 @@ _ACEOF
#--------------------------------------------------------------------
if test "$ac_cv_cygwin" != "yes"; then
- echo "$as_me:$LINENO: checking for struct stat.st_blocks" >&5
-echo $ECHO_N "checking for struct stat.st_blocks... $ECHO_C" >&6
-if test "${ac_cv_member_struct_stat_st_blocks+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static struct stat ac_aggr;
-if (ac_aggr.st_blocks)
-return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_member_struct_stat_st_blocks=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ ac_fn_c_check_member "$LINENO" "struct stat" "st_blocks" "ac_cv_member_struct_stat_st_blocks" "$ac_includes_default"
+if test "x$ac_cv_member_struct_stat_st_blocks" = xyes
+then :
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static struct stat ac_aggr;
-if (sizeof ac_aggr.st_blocks)
-return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_member_struct_stat_st_blocks=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_member_struct_stat_st_blocks=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blocks" >&5
-echo "${ECHO_T}$ac_cv_member_struct_stat_st_blocks" >&6
-if test $ac_cv_member_struct_stat_st_blocks = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_STRUCT_STAT_ST_BLOCKS 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLOCKS 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for struct stat.st_blksize" >&5
-echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6
-if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static struct stat ac_aggr;
-if (ac_aggr.st_blksize)
-return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_member_struct_stat_st_blksize=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static struct stat ac_aggr;
-if (sizeof ac_aggr.st_blksize)
-return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_member_struct_stat_st_blksize=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_member_struct_stat_st_blksize=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blksize" >&5
-echo "${ECHO_T}$ac_cv_member_struct_stat_st_blksize" >&6
-if test $ac_cv_member_struct_stat_st_blksize = yes; then
+ac_fn_c_check_member "$LINENO" "struct stat" "st_blksize" "ac_cv_member_struct_stat_st_blksize" "$ac_includes_default"
+if test "x$ac_cv_member_struct_stat_st_blksize" = xyes
+then :
-cat >>confdefs.h <<_ACEOF
-#define HAVE_STRUCT_STAT_ST_BLKSIZE 1
-_ACEOF
+printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLKSIZE 1" >>confdefs.h
fi
fi
-echo "$as_me:$LINENO: checking for blkcnt_t" >&5
-echo $ECHO_N "checking for blkcnt_t... $ECHO_C" >&6
-if test "${ac_cv_type_blkcnt_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((blkcnt_t *) 0)
- return 0;
-if (sizeof (blkcnt_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_blkcnt_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_type "$LINENO" "blkcnt_t" "ac_cv_type_blkcnt_t" "$ac_includes_default"
+if test "x$ac_cv_type_blkcnt_t" = xyes
+then :
-ac_cv_type_blkcnt_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_blkcnt_t" >&5
-echo "${ECHO_T}$ac_cv_type_blkcnt_t" >&6
-if test $ac_cv_type_blkcnt_t = yes; then
-
-cat >>confdefs.h <<_ACEOF
-#define HAVE_BLKCNT_T 1
-_ACEOF
+printf "%s\n" "#define HAVE_BLKCNT_T 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for fstatfs" >&5
-echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6
-if test "${ac_cv_func_fstatfs+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define fstatfs to an innocuous variant, in case <limits.h> declares fstatfs.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define fstatfs innocuous_fstatfs
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char fstatfs (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef fstatfs
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char fstatfs ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_fstatfs) || defined (__stub___fstatfs)
-choke me
-#else
-char (*f) () = fstatfs;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != fstatfs;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_fstatfs=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_func "$LINENO" "fstatfs" "ac_cv_func_fstatfs"
+if test "x$ac_cv_func_fstatfs" = xyes
+then :
-ac_cv_func_fstatfs=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_fstatfs" >&5
-echo "${ECHO_T}$ac_cv_func_fstatfs" >&6
-if test $ac_cv_func_fstatfs = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define NO_FSTATFS 1
-_ACEOF
+printf "%s\n" "#define NO_FSTATFS 1" >>confdefs.h
fi
@@ -14913,29 +9533,27 @@ fi
# checks it and add memcmp.o to LIBOBJS if needed
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for working memcmp" >&5
-echo $ECHO_N "checking for working memcmp... $ECHO_C" >&6
-if test "${ac_cv_func_memcmp_working+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if test "$cross_compiling" = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working memcmp" >&5
+printf %s "checking for working memcmp... " >&6; }
+if test ${ac_cv_func_memcmp_working+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test "$cross_compiling" = yes
+then :
ac_cv_func_memcmp_working=no
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_includes_default
int
-main ()
+main (void)
{
/* Some versions of memcmp are not 8-bit clean. */
- char c0 = 0x40, c1 = 0x80, c2 = 0x81;
+ char c0 = '\100', c1 = '\200', c2 = '\201';
if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0)
- exit (1);
+ return 1;
/* The Next x86 OpenStep bug shows up only when comparing 16 bytes
or more and with at least one buffer not starting on a 4-byte boundary.
@@ -14951,46 +9569,32 @@ main ()
strcpy (a, "--------01111111");
strcpy (b, "--------10000000");
if (memcmp (a, b, 16) >= 0)
- exit (1);
+ return 1;
}
- exit (0);
+ return 0;
}
;
return 0;
}
_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_run "$LINENO"
+then :
ac_cv_func_memcmp_working=yes
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-ac_cv_func_memcmp_working=no
+else $as_nop
+ ac_cv_func_memcmp_working=no
fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
+
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5
-echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6
-test $ac_cv_func_memcmp_working = no && case $LIBOBJS in
- "memcmp.$ac_objext" | \
- *" memcmp.$ac_objext" | \
- "memcmp.$ac_objext "* | \
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_memcmp_working" >&5
+printf "%s\n" "$ac_cv_func_memcmp_working" >&6; }
+test $ac_cv_func_memcmp_working = no && case " $LIBOBJS " in
*" memcmp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS memcmp.$ac_objext"
+ ;;
esac
@@ -15001,109 +9605,17 @@ esac
# compat/string.h}
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for memmove" >&5
-echo $ECHO_N "checking for memmove... $ECHO_C" >&6
-if test "${ac_cv_func_memmove+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define memmove to an innocuous variant, in case <limits.h> declares memmove.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define memmove innocuous_memmove
+ac_fn_c_check_func "$LINENO" "memmove" "ac_cv_func_memmove"
+if test "x$ac_cv_func_memmove" = xyes
+then :
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char memmove (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+else $as_nop
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-#undef memmove
+printf "%s\n" "#define NO_MEMMOVE 1" >>confdefs.h
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char memmove ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_memmove) || defined (__stub___memmove)
-choke me
-#else
-char (*f) () = memmove;
-#endif
-#ifdef __cplusplus
-}
-#endif
-int
-main ()
-{
-return f != memmove;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_memmove=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_memmove=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_memmove" >&5
-echo "${ECHO_T}$ac_cv_func_memmove" >&6
-if test $ac_cv_func_memmove = yes; then
- :
-else
-
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_MEMMOVE 1
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_STRING_H 1
-_ACEOF
+printf "%s\n" "#define NO_STRING_H 1" >>confdefs.h
fi
@@ -15114,116 +9626,26 @@ fi
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for strstr" >&5
-echo $ECHO_N "checking for strstr... $ECHO_C" >&6
-if test "${ac_cv_func_strstr+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define strstr to an innocuous variant, in case <limits.h> declares strstr.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define strstr innocuous_strstr
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char strstr (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef strstr
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char strstr ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_strstr) || defined (__stub___strstr)
-choke me
-#else
-char (*f) () = strstr;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != strstr;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_strstr=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_strstr=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_strstr" >&5
-echo "${ECHO_T}$ac_cv_func_strstr" >&6
-if test $ac_cv_func_strstr = yes; then
+ ac_fn_c_check_func "$LINENO" "strstr" "ac_cv_func_strstr"
+if test "x$ac_cv_func_strstr" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
if test "$tcl_ok" = 1; then
- echo "$as_me:$LINENO: checking proper strstr implementation" >&5
-echo $ECHO_N "checking proper strstr implementation... $ECHO_C" >&6
-if test "${tcl_cv_strstr_unbroken+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if test "$cross_compiling" = yes; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking proper strstr implementation" >&5
+printf %s "checking proper strstr implementation... " >&6; }
+if test ${tcl_cv_strstr_unbroken+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test "$cross_compiling" = yes
+then :
tcl_cv_strstr_unbroken=unknown
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
@@ -15232,31 +9654,19 @@ int main() {
exit(strstr("\0test", "test") ? 1 : 0);
}
_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_run "$LINENO"
+then :
tcl_cv_strstr_unbroken=ok
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-tcl_cv_strstr_unbroken=broken
+else $as_nop
+ tcl_cv_strstr_unbroken=broken
fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
+
fi
-echo "$as_me:$LINENO: result: $tcl_cv_strstr_unbroken" >&5
-echo "${ECHO_T}$tcl_cv_strstr_unbroken" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strstr_unbroken" >&5
+printf "%s\n" "$tcl_cv_strstr_unbroken" >&6; }
if test "$tcl_cv_strstr_unbroken" = "ok"; then
tcl_ok=1
else
@@ -15264,12 +9674,10 @@ echo "${ECHO_T}$tcl_cv_strstr_unbroken" >&6
fi
fi
if test "$tcl_ok" = 0; then
- case $LIBOBJS in
- "strstr.$ac_objext" | \
- *" strstr.$ac_objext" | \
- "strstr.$ac_objext "* | \
+ case " $LIBOBJS " in
*" strstr.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS strstr.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS strstr.$ac_objext"
+ ;;
esac
USE_COMPAT=1
@@ -15283,116 +9691,26 @@ esac
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for strtoul" >&5
-echo $ECHO_N "checking for strtoul... $ECHO_C" >&6
-if test "${ac_cv_func_strtoul+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define strtoul to an innocuous variant, in case <limits.h> declares strtoul.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define strtoul innocuous_strtoul
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char strtoul (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef strtoul
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char strtoul ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_strtoul) || defined (__stub___strtoul)
-choke me
-#else
-char (*f) () = strtoul;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != strtoul;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_strtoul=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_strtoul=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_strtoul" >&5
-echo "${ECHO_T}$ac_cv_func_strtoul" >&6
-if test $ac_cv_func_strtoul = yes; then
+ ac_fn_c_check_func "$LINENO" "strtoul" "ac_cv_func_strtoul"
+if test "x$ac_cv_func_strtoul" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
if test "$tcl_ok" = 1; then
- echo "$as_me:$LINENO: checking proper strtoul implementation" >&5
-echo $ECHO_N "checking proper strtoul implementation... $ECHO_C" >&6
-if test "${tcl_cv_strtoul_unbroken+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if test "$cross_compiling" = yes; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking proper strtoul implementation" >&5
+printf %s "checking proper strtoul implementation... " >&6; }
+if test ${tcl_cv_strtoul_unbroken+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test "$cross_compiling" = yes
+then :
tcl_cv_strtoul_unbroken=unknown
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
@@ -15402,31 +9720,19 @@ int main() {
exit(strtoul(string,&term,0) != 0 || term != string+1);
}
_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_run "$LINENO"
+then :
tcl_cv_strtoul_unbroken=ok
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-tcl_cv_strtoul_unbroken=broken
+else $as_nop
+ tcl_cv_strtoul_unbroken=broken
fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
+
fi
-echo "$as_me:$LINENO: result: $tcl_cv_strtoul_unbroken" >&5
-echo "${ECHO_T}$tcl_cv_strtoul_unbroken" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtoul_unbroken" >&5
+printf "%s\n" "$tcl_cv_strtoul_unbroken" >&6; }
if test "$tcl_cv_strtoul_unbroken" = "ok"; then
tcl_ok=1
else
@@ -15434,12 +9740,10 @@ echo "${ECHO_T}$tcl_cv_strtoul_unbroken" >&6
fi
fi
if test "$tcl_ok" = 0; then
- case $LIBOBJS in
- "strtoul.$ac_objext" | \
- *" strtoul.$ac_objext" | \
- "strtoul.$ac_objext "* | \
+ case " $LIBOBJS " in
*" strtoul.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS strtoul.$ac_objext"
+ ;;
esac
USE_COMPAT=1
@@ -15451,261 +9755,111 @@ esac
# they don't exist.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for mode_t" >&5
-echo $ECHO_N "checking for mode_t... $ECHO_C" >&6
-if test "${ac_cv_type_mode_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((mode_t *) 0)
- return 0;
-if (sizeof (mode_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_mode_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_type "$LINENO" "mode_t" "ac_cv_type_mode_t" "$ac_includes_default"
+if test "x$ac_cv_type_mode_t" = xyes
+then :
-ac_cv_type_mode_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5
-echo "${ECHO_T}$ac_cv_type_mode_t" >&6
-if test $ac_cv_type_mode_t = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<_ACEOF
-#define mode_t int
-_ACEOF
+printf "%s\n" "#define mode_t int" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for pid_t" >&5
-echo $ECHO_N "checking for pid_t... $ECHO_C" >&6
-if test "${ac_cv_type_pid_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+
+ ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default
+"
+if test "x$ac_cv_type_pid_t" = xyes
+then :
+
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-$ac_includes_default
+
+ #if defined _WIN64 && !defined __CYGWIN__
+ LLP64
+ #endif
+
int
-main ()
+main (void)
{
-if ((pid_t *) 0)
- return 0;
-if (sizeof (pid_t))
- return 0;
+
;
return 0;
}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_pid_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-ac_cv_type_pid_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_pid_type='int'
+else $as_nop
+ ac_pid_type='__int64'
fi
-echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5
-echo "${ECHO_T}$ac_cv_type_pid_t" >&6
-if test $ac_cv_type_pid_t = yes; then
- :
-else
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+
+printf "%s\n" "#define pid_t $ac_pid_type" >>confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define pid_t int
-_ACEOF
fi
-echo "$as_me:$LINENO: checking for size_t" >&5
-echo $ECHO_N "checking for size_t... $ECHO_C" >&6
-if test "${ac_cv_type_size_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((size_t *) 0)
- return 0;
-if (sizeof (size_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_size_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-ac_cv_type_size_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5
-echo "${ECHO_T}$ac_cv_type_size_t" >&6
-if test $ac_cv_type_size_t = yes; then
- :
-else
+ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default"
+if test "x$ac_cv_type_size_t" = xyes
+then :
-cat >>confdefs.h <<_ACEOF
-#define size_t unsigned
-_ACEOF
+else $as_nop
+
+printf "%s\n" "#define size_t unsigned int" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for uid_t in sys/types.h" >&5
-echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6
-if test "${ac_cv_type_uid_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for uid_t in sys/types.h" >&5
+printf %s "checking for uid_t in sys/types.h... " >&6; }
+if test ${ac_cv_type_uid_t+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "uid_t" >/dev/null 2>&1; then
+ $EGREP "uid_t" >/dev/null 2>&1
+then :
ac_cv_type_uid_t=yes
-else
+else $as_nop
ac_cv_type_uid_t=no
fi
-rm -f conftest*
+rm -rf conftest*
fi
-echo "$as_me:$LINENO: result: $ac_cv_type_uid_t" >&5
-echo "${ECHO_T}$ac_cv_type_uid_t" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_uid_t" >&5
+printf "%s\n" "$ac_cv_type_uid_t" >&6; }
if test $ac_cv_type_uid_t = no; then
-cat >>confdefs.h <<\_ACEOF
-#define uid_t int
-_ACEOF
+printf "%s\n" "#define uid_t int" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define gid_t int
-_ACEOF
+printf "%s\n" "#define gid_t int" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for socklen_t" >&5
-echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6
-if test "${tcl_cv_type_socklen_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for socklen_t" >&5
+printf %s "checking for socklen_t... " >&6; }
+if test ${tcl_cv_type_socklen_t+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <sys/socket.h>
int
-main ()
+main (void)
{
socklen_t foo;
@@ -15714,315 +9868,42 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_type_socklen_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_type_socklen_t=no
+else $as_nop
+ tcl_cv_type_socklen_t=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_type_socklen_t" >&5
-echo "${ECHO_T}$tcl_cv_type_socklen_t" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_socklen_t" >&5
+printf "%s\n" "$tcl_cv_type_socklen_t" >&6; }
if test $tcl_cv_type_socklen_t = no; then
-cat >>confdefs.h <<\_ACEOF
-#define socklen_t int
-_ACEOF
+printf "%s\n" "#define socklen_t int" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking for intptr_t" >&5
-echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6
-if test "${ac_cv_type_intptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((intptr_t *) 0)
- return 0;
-if (sizeof (intptr_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_intptr_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_intptr_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_intptr_t" >&5
-echo "${ECHO_T}$ac_cv_type_intptr_t" >&6
-if test $ac_cv_type_intptr_t = yes; then
-
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_INTPTR_T 1
-_ACEOF
+ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "
+#include <stdint.h>
-else
+"
+if test "x$ac_cv_type_intptr_t" = xyes
+then :
- echo "$as_me:$LINENO: checking for pointer-size signed integer type" >&5
-echo $ECHO_N "checking for pointer-size signed integer type... $ECHO_C" >&6
-if test "${tcl_cv_intptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+printf "%s\n" "#define HAVE_INTPTR_T 1" >>confdefs.h
- for tcl_cv_intptr_t in "int" "long" "long long" none; do
- if test "$tcl_cv_intptr_t" != none; then
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))];
-test_array [0] = 0
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_ok=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- test "$tcl_ok" = yes && break; fi
- done
fi
-echo "$as_me:$LINENO: result: $tcl_cv_intptr_t" >&5
-echo "${ECHO_T}$tcl_cv_intptr_t" >&6
- if test "$tcl_cv_intptr_t" != none; then
-
-cat >>confdefs.h <<_ACEOF
-#define intptr_t $tcl_cv_intptr_t
-_ACEOF
+ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "
+#include <stdint.h>
- fi
+"
+if test "x$ac_cv_type_uintptr_t" = xyes
+then :
-fi
+printf "%s\n" "#define HAVE_UINTPTR_T 1" >>confdefs.h
-echo "$as_me:$LINENO: checking for uintptr_t" >&5
-echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6
-if test "${ac_cv_type_uintptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((uintptr_t *) 0)
- return 0;
-if (sizeof (uintptr_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_uintptr_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_uintptr_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5
-echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6
-if test $ac_cv_type_uintptr_t = yes; then
-
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_UINTPTR_T 1
-_ACEOF
-
-else
-
- echo "$as_me:$LINENO: checking for pointer-size unsigned integer type" >&5
-echo $ECHO_N "checking for pointer-size unsigned integer type... $ECHO_C" >&6
-if test "${tcl_cv_uintptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \
- none; do
- if test "$tcl_cv_uintptr_t" != none; then
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))];
-test_array [0] = 0
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_ok=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- test "$tcl_ok" = yes && break; fi
- done
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_uintptr_t" >&5
-echo "${ECHO_T}$tcl_cv_uintptr_t" >&6
- if test "$tcl_cv_uintptr_t" != none; then
-
-cat >>confdefs.h <<_ACEOF
-#define uintptr_t $tcl_cv_uintptr_t
-_ACEOF
-
- fi
fi
@@ -16034,103 +9915,13 @@ fi
# provided. This version only works with V7-style directories.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for opendir" >&5
-echo $ECHO_N "checking for opendir... $ECHO_C" >&6
-if test "${ac_cv_func_opendir+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define opendir to an innocuous variant, in case <limits.h> declares opendir.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define opendir innocuous_opendir
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char opendir (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef opendir
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char opendir ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_opendir) || defined (__stub___opendir)
-choke me
-#else
-char (*f) () = opendir;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != opendir;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_opendir=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir"
+if test "x$ac_cv_func_opendir" = xyes
+then :
-ac_cv_func_opendir=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_opendir" >&5
-echo "${ECHO_T}$ac_cv_func_opendir" >&6
-if test $ac_cv_func_opendir = yes; then
- :
-else
+else $as_nop
-cat >>confdefs.h <<\_ACEOF
-#define USE_DIRENT2_H 1
-_ACEOF
+printf "%s\n" "#define USE_DIRENT2_H 1" >>confdefs.h
fi
@@ -16143,22 +9934,19 @@ fi
# the trick.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking union wait" >&5
-echo $ECHO_N "checking union wait... $ECHO_C" >&6
-if test "${tcl_cv_union_wait+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking union wait" >&5
+printf %s "checking union wait... " >&6; }
+if test ${tcl_cv_union_wait+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <sys/wait.h>
int
-main ()
+main (void)
{
union wait x;
@@ -16169,45 +9957,20 @@ WIFEXITED(x); /* Generates compiler error if WIFEXITED
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_union_wait=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_union_wait=no
+else $as_nop
+ tcl_cv_union_wait=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5
-echo "${ECHO_T}$tcl_cv_union_wait" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_union_wait" >&5
+printf "%s\n" "$tcl_cv_union_wait" >&6; }
if test $tcl_cv_union_wait = no; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_UNION_WAIT 1
-_ACEOF
+printf "%s\n" "#define NO_UNION_WAIT 1" >>confdefs.h
fi
@@ -16217,253 +9980,107 @@ fi
# under Sequent Dynix it's in -linet.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for strncasecmp" >&5
-echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6
-if test "${ac_cv_func_strncasecmp+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define strncasecmp to an innocuous variant, in case <limits.h> declares strncasecmp.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define strncasecmp innocuous_strncasecmp
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char strncasecmp (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef strncasecmp
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char strncasecmp ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_strncasecmp) || defined (__stub___strncasecmp)
-choke me
-#else
-char (*f) () = strncasecmp;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != strncasecmp;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_strncasecmp=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_strncasecmp=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_func_strncasecmp" >&5
-echo "${ECHO_T}$ac_cv_func_strncasecmp" >&6
-if test $ac_cv_func_strncasecmp = yes; then
+ac_fn_c_check_func "$LINENO" "strncasecmp" "ac_cv_func_strncasecmp"
+if test "x$ac_cv_func_strncasecmp" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
if test "$tcl_ok" = 0; then
- echo "$as_me:$LINENO: checking for strncasecmp in -lsocket" >&5
-echo $ECHO_N "checking for strncasecmp in -lsocket... $ECHO_C" >&6
-if test "${ac_cv_lib_socket_strncasecmp+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -lsocket" >&5
+printf %s "checking for strncasecmp in -lsocket... " >&6; }
+if test ${ac_cv_lib_socket_strncasecmp+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char strncasecmp ();
int
-main ()
+main (void)
{
-strncasecmp ();
+return strncasecmp ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_socket_strncasecmp=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_socket_strncasecmp=no
+else $as_nop
+ ac_cv_lib_socket_strncasecmp=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_socket_strncasecmp" >&5
-echo "${ECHO_T}$ac_cv_lib_socket_strncasecmp" >&6
-if test $ac_cv_lib_socket_strncasecmp = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_strncasecmp" >&5
+printf "%s\n" "$ac_cv_lib_socket_strncasecmp" >&6; }
+if test "x$ac_cv_lib_socket_strncasecmp" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
- echo "$as_me:$LINENO: checking for strncasecmp in -linet" >&5
-echo $ECHO_N "checking for strncasecmp in -linet... $ECHO_C" >&6
-if test "${ac_cv_lib_inet_strncasecmp+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -linet" >&5
+printf %s "checking for strncasecmp in -linet... " >&6; }
+if test ${ac_cv_lib_inet_strncasecmp+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-linet $LIBS"
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-#endif
-/* We use char because int might match the return type of a gcc2
+/* Override any GCC internal prototype to avoid an error.
+ Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char strncasecmp ();
int
-main ()
+main (void)
{
-strncasecmp ();
+return strncasecmp ();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_lib_inet_strncasecmp=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_lib_inet_strncasecmp=no
+else $as_nop
+ ac_cv_lib_inet_strncasecmp=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
-echo "$as_me:$LINENO: result: $ac_cv_lib_inet_strncasecmp" >&5
-echo "${ECHO_T}$ac_cv_lib_inet_strncasecmp" >&6
-if test $ac_cv_lib_inet_strncasecmp = yes; then
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_strncasecmp" >&5
+printf "%s\n" "$ac_cv_lib_inet_strncasecmp" >&6; }
+if test "x$ac_cv_lib_inet_strncasecmp" = xyes
+then :
tcl_ok=1
-else
+else $as_nop
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
- case $LIBOBJS in
- "strncasecmp.$ac_objext" | \
- *" strncasecmp.$ac_objext" | \
- "strncasecmp.$ac_objext "* | \
+ case " $LIBOBJS " in
*" strncasecmp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" ;;
+ *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext"
+ ;;
esac
USE_COMPAT=1
@@ -16478,139 +10095,45 @@ fi
# declare it.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for gettimeofday" >&5
-echo $ECHO_N "checking for gettimeofday... $ECHO_C" >&6
-if test "${ac_cv_func_gettimeofday+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define gettimeofday to an innocuous variant, in case <limits.h> declares gettimeofday.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define gettimeofday innocuous_gettimeofday
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char gettimeofday (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
+ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday"
+if test "x$ac_cv_func_gettimeofday" = xyes
+then :
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+else $as_nop
-#undef gettimeofday
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gettimeofday ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_gettimeofday) || defined (__stub___gettimeofday)
-choke me
-#else
-char (*f) () = gettimeofday;
-#endif
-#ifdef __cplusplus
-}
-#endif
+printf "%s\n" "#define NO_GETTOD 1" >>confdefs.h
-int
-main ()
-{
-return f != gettimeofday;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_func_gettimeofday=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-ac_cv_func_gettimeofday=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_func_gettimeofday" >&5
-echo "${ECHO_T}$ac_cv_func_gettimeofday" >&6
-if test $ac_cv_func_gettimeofday = yes; then
- :
-else
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_GETTOD 1
-_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5
+printf %s "checking for gettimeofday declaration... " >&6; }
+if test ${tcl_cv_grep_gettimeofday+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
-
-fi
-
-echo "$as_me:$LINENO: checking for gettimeofday declaration" >&5
-echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6
-if test "${tcl_cv_grep_gettimeofday+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/time.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "gettimeofday" >/dev/null 2>&1; then
+ $EGREP "gettimeofday" >/dev/null 2>&1
+then :
tcl_cv_grep_gettimeofday=present
-else
+else $as_nop
tcl_cv_grep_gettimeofday=missing
fi
-rm -f conftest*
+rm -rf conftest*
fi
-echo "$as_me:$LINENO: result: $tcl_cv_grep_gettimeofday" >&5
-echo "${ECHO_T}$tcl_cv_grep_gettimeofday" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_gettimeofday" >&5
+printf "%s\n" "$tcl_cv_grep_gettimeofday" >&6; }
if test $tcl_cv_grep_gettimeofday = missing ; then
-cat >>confdefs.h <<\_ACEOF
-#define GETTOD_NOT_DECLARED 1
-_ACEOF
+printf "%s\n" "#define GETTOD_NOT_DECLARED 1" >>confdefs.h
fi
@@ -16620,84 +10143,53 @@ fi
# properly generate sign-extended ints from character values.
#--------------------------------------------------------------------
-
-echo "$as_me:$LINENO: checking whether char is unsigned" >&5
-echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6
-if test "${ac_cv_c_char_unsigned+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether char is unsigned" >&5
+printf %s "checking whether char is unsigned... " >&6; }
+if test ${ac_cv_c_char_unsigned+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_includes_default
int
-main ()
+main (void)
{
static int test_array [1 - 2 * !(((char) -1) < 0)];
-test_array [0] = 0
+test_array [0] = 0;
+return test_array [0];
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_c_char_unsigned=no
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_c_char_unsigned=yes
+else $as_nop
+ ac_cv_c_char_unsigned=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5
-echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6
-if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then
- cat >>confdefs.h <<\_ACEOF
-#define __CHAR_UNSIGNED__ 1
-_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_char_unsigned" >&5
+printf "%s\n" "$ac_cv_c_char_unsigned" >&6; }
+if test $ac_cv_c_char_unsigned = yes; then
+ printf "%s\n" "#define __CHAR_UNSIGNED__ 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: checking signed char declarations" >&5
-echo $ECHO_N "checking signed char declarations... $ECHO_C" >&6
-if test "${tcl_cv_char_signed+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking signed char declarations" >&5
+printf %s "checking signed char declarations... " >&6; }
+if test ${tcl_cv_char_signed+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
signed char *p;
@@ -16707,44 +10199,19 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_char_signed=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_char_signed=no
+else $as_nop
+ tcl_cv_char_signed=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5
-echo "${ECHO_T}$tcl_cv_char_signed" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_char_signed" >&5
+printf "%s\n" "$tcl_cv_char_signed" >&6; }
if test $tcl_cv_char_signed = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_SIGNED_CHAR 1
-_ACEOF
+printf "%s\n" "#define HAVE_SIGNED_CHAR 1" >>confdefs.h
fi
@@ -16752,20 +10219,18 @@ fi
# Does putenv() copy or not? We need to know to avoid memory leaks.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for a putenv() that copies the buffer" >&5
-echo $ECHO_N "checking for a putenv() that copies the buffer... $ECHO_C" >&6
-if test "${tcl_cv_putenv_copy+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a putenv() that copies the buffer" >&5
+printf %s "checking for a putenv() that copies the buffer... " >&6; }
+if test ${tcl_cv_putenv_copy+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- if test "$cross_compiling" = yes; then
+ if test "$cross_compiling" = yes
+then :
tcl_cv_putenv_copy=no
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
@@ -16788,36 +10253,22 @@ cat >>conftest.$ac_ext <<_ACEOF
}
_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_run "$LINENO"
+then :
tcl_cv_putenv_copy=no
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-tcl_cv_putenv_copy=yes
+else $as_nop
+ tcl_cv_putenv_copy=yes
fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
+
fi
-echo "$as_me:$LINENO: result: $tcl_cv_putenv_copy" >&5
-echo "${ECHO_T}$tcl_cv_putenv_copy" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_putenv_copy" >&5
+printf "%s\n" "$tcl_cv_putenv_copy" >&6; }
if test $tcl_cv_putenv_copy = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_PUTENV_THAT_COPIES 1
-_ACEOF
+printf "%s\n" "#define HAVE_PUTENV_THAT_COPIES 1" >>confdefs.h
fi
@@ -16826,1203 +10277,162 @@ fi
#--------------------------------------------------------------------
- # Check whether --enable-langinfo or --disable-langinfo was given.
-if test "${enable_langinfo+set}" = set; then
- enableval="$enable_langinfo"
- langinfo_ok=$enableval
-else
+ # Check whether --enable-langinfo was given.
+if test ${enable_langinfo+y}
+then :
+ enableval=$enable_langinfo; langinfo_ok=$enableval
+else $as_nop
langinfo_ok=yes
-fi;
-
- HAVE_LANGINFO=0
- if test "$langinfo_ok" = "yes"; then
- if test "${ac_cv_header_langinfo_h+set}" = set; then
- echo "$as_me:$LINENO: checking for langinfo.h" >&5
-echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6
-if test "${ac_cv_header_langinfo_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5
-echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking langinfo.h usability" >&5
-echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <langinfo.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking langinfo.h presence" >&5
-echo $ECHO_N "checking langinfo.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <langinfo.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: langinfo.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: langinfo.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: langinfo.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: langinfo.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: langinfo.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: langinfo.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: langinfo.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: langinfo.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: langinfo.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for langinfo.h" >&5
-echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6
-if test "${ac_cv_header_langinfo_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_langinfo_h=$ac_header_preproc
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5
-echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6
-fi
-if test $ac_cv_header_langinfo_h = yes; then
+ HAVE_LANGINFO=0
+ if test "$langinfo_ok" = "yes"; then
+ ac_fn_c_check_header_compile "$LINENO" "langinfo.h" "ac_cv_header_langinfo_h" "$ac_includes_default"
+if test "x$ac_cv_header_langinfo_h" = xyes
+then :
langinfo_ok=yes
-else
+else $as_nop
langinfo_ok=no
fi
-
fi
- echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5
-echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use nl_langinfo" >&5
+printf %s "checking whether to use nl_langinfo... " >&6; }
if test "$langinfo_ok" = "yes"; then
- if test "${tcl_cv_langinfo_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ if test ${tcl_cv_langinfo_h+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <langinfo.h>
int
-main ()
+main (void)
{
nl_langinfo(CODESET);
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_langinfo_h=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_langinfo_h=no
+else $as_nop
+ tcl_cv_langinfo_h=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
- echo "$as_me:$LINENO: result: $tcl_cv_langinfo_h" >&5
-echo "${ECHO_T}$tcl_cv_langinfo_h" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_langinfo_h" >&5
+printf "%s\n" "$tcl_cv_langinfo_h" >&6; }
if test $tcl_cv_langinfo_h = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_LANGINFO 1
-_ACEOF
+printf "%s\n" "#define HAVE_LANGINFO 1" >>confdefs.h
fi
else
- echo "$as_me:$LINENO: result: $langinfo_ok" >&5
-echo "${ECHO_T}$langinfo_ok" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
+printf "%s\n" "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
-# Check for support of chflags and mkstemps functions
+# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
+ac_fn_c_check_func "$LINENO" "cfmakeraw" "ac_cv_func_cfmakeraw"
+if test "x$ac_cv_func_cfmakeraw" = xyes
+then :
+ printf "%s\n" "#define HAVE_CFMAKERAW 1" >>confdefs.h
-
-for ac_func in chflags mkstemps
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
+ac_fn_c_check_func "$LINENO" "chflags" "ac_cv_func_chflags"
+if test "x$ac_cv_func_chflags" = xyes
+then :
+ printf "%s\n" "#define HAVE_CHFLAGS 1" >>confdefs.h
fi
-done
-
+ac_fn_c_check_func "$LINENO" "mkstemps" "ac_cv_func_mkstemps"
+if test "x$ac_cv_func_mkstemps" = xyes
+then :
+ printf "%s\n" "#define HAVE_MKSTEMPS 1" >>confdefs.h
-#--------------------------------------------------------------------
-# Check for support of isnan() function or macro
-#--------------------------------------------------------------------
-
-echo "$as_me:$LINENO: checking isnan" >&5
-echo $ECHO_N "checking isnan... $ECHO_C" >&6
-if test "${tcl_cv_isnan+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <math.h>
-int
-main ()
-{
-
-isnan(0.0); /* Generates an error if isnan is missing */
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_cv_isnan=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_isnan=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_isnan" >&5
-echo "${ECHO_T}$tcl_cv_isnan" >&6
-if test $tcl_cv_isnan = no; then
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_ISNAN 1
-_ACEOF
-fi
#--------------------------------------------------------------------
# Darwin specific API checks and defines
#--------------------------------------------------------------------
if test "`uname -s`" = "Darwin" ; then
+ ac_fn_c_check_func "$LINENO" "getattrlist" "ac_cv_func_getattrlist"
+if test "x$ac_cv_func_getattrlist" = xyes
+then :
+ printf "%s\n" "#define HAVE_GETATTRLIST 1" >>confdefs.h
-for ac_func in getattrlist
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-done
-
-
-for ac_header in copyfile.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
+ ac_fn_c_check_header_compile "$LINENO" "copyfile.h" "ac_cv_header_copyfile_h" "$ac_includes_default"
+if test "x$ac_cv_header_copyfile_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_COPYFILE_H 1" >>confdefs.h
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+ ac_fn_c_check_func "$LINENO" "copyfile" "ac_cv_func_copyfile"
+if test "x$ac_cv_func_copyfile" = xyes
+then :
+ printf "%s\n" "#define HAVE_COPYFILE 1" >>confdefs.h
fi
-done
-
-
-for ac_func in copyfile
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-done
-
if test $tcl_corefoundation = yes; then
+ ac_fn_c_check_header_compile "$LINENO" "libkern/OSAtomic.h" "ac_cv_header_libkern_OSAtomic_h" "$ac_includes_default"
+if test "x$ac_cv_header_libkern_OSAtomic_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_LIBKERN_OSATOMIC_H 1" >>confdefs.h
-for ac_header in libkern/OSAtomic.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ ac_fn_c_check_func "$LINENO" "OSSpinLockLock" "ac_cv_func_OSSpinLockLock"
+if test "x$ac_cv_func_OSSpinLockLock" = xyes
+then :
+ printf "%s\n" "#define HAVE_OSSPINLOCKLOCK 1" >>confdefs.h
- ac_header_preproc=no
fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-
-done
-
-
-for ac_func in OSSpinLockLock
-do
-as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_func" >&5
-echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6
-if eval "test \"\${$as_ac_var+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.
- For example, HP-UX 11i <limits.h> declares gettimeofday. */
-#define $ac_func innocuous_$ac_func
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func (); below.
- Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- <limits.h> exists even on freestanding compilers. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef $ac_func
-
-/* Override any gcc2 internal prototype to avoid an error. */
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func ();
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-char (*f) () = $ac_func;
-#endif
-#ifdef __cplusplus
-}
-#endif
-
-int
-main ()
-{
-return f != $ac_func;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_var=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-eval "$as_ac_var=no"
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6
-if test `eval echo '${'$as_ac_var'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-done
fi
-cat >>confdefs.h <<\_ACEOF
-#define USE_VFORK 1
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define TCL_DEFAULT_ENCODING "utf-8"
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define TCL_LOAD_FROM_MEMORY 1
-_ACEOF
-
+printf "%s\n" "#define USE_VFORK 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define TCL_WIDE_CLICKS 1
-_ACEOF
+printf "%s\n" "#define TCL_DEFAULT_ENCODING \"utf-8\"" >>confdefs.h
-for ac_header in AvailabilityMacros.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+printf "%s\n" "#define TCL_LOAD_FROM_MEMORY 1" >>confdefs.h
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
+printf "%s\n" "#define TCL_WIDE_CLICKS 1" >>confdefs.h
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+ ac_fn_c_check_header_compile "$LINENO" "AvailabilityMacros.h" "ac_cv_header_AvailabilityMacros_h" "$ac_includes_default"
+if test "x$ac_cv_header_AvailabilityMacros_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_AVAILABILITYMACROS_H 1" >>confdefs.h
fi
-done
-
if test "$ac_cv_header_AvailabilityMacros_h" = yes; then
- echo "$as_me:$LINENO: checking if weak import is available" >&5
-echo $ECHO_N "checking if weak import is available... $ECHO_C" >&6
-if test "${tcl_cv_cc_weak_import+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if weak import is available" >&5
+printf %s "checking if weak import is available... " >&6; }
+if test ${tcl_cv_cc_weak_import+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
@@ -18035,67 +10445,39 @@ cat >>conftest.$ac_ext <<_ACEOF
int rand(void) __attribute__((weak_import));
int
-main ()
+main (void)
{
rand();
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cc_weak_import=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_weak_import=no
+else $as_nop
+ tcl_cv_cc_weak_import=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_weak_import" >&5
-echo "${ECHO_T}$tcl_cv_cc_weak_import" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_weak_import" >&5
+printf "%s\n" "$tcl_cv_cc_weak_import" >&6; }
if test $tcl_cv_cc_weak_import = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_WEAK_IMPORT 1
-_ACEOF
+printf "%s\n" "#define HAVE_WEAK_IMPORT 1" >>confdefs.h
fi
- echo "$as_me:$LINENO: checking if Darwin SUSv3 extensions are available" >&5
-echo $ECHO_N "checking if Darwin SUSv3 extensions are available... $ECHO_C" >&6
-if test "${tcl_cv_cc_darwin_c_source+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if Darwin SUSv3 extensions are available" >&5
+printf %s "checking if Darwin SUSv3 extensions are available... " >&6; }
+if test ${tcl_cv_cc_darwin_c_source+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
@@ -18109,52 +10491,27 @@ cat >>conftest.$ac_ext <<_ACEOF
#include <sys/cdefs.h>
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_cc_darwin_c_source=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_darwin_c_source=no
+else $as_nop
+ tcl_cv_cc_darwin_c_source=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_darwin_c_source" >&5
-echo "${ECHO_T}$tcl_cv_cc_darwin_c_source" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_darwin_c_source" >&5
+printf "%s\n" "$tcl_cv_cc_darwin_c_source" >&6; }
if test $tcl_cv_cc_darwin_c_source = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define _DARWIN_C_SOURCE 1
-_ACEOF
+printf "%s\n" "#define _DARWIN_C_SOURCE 1" >>confdefs.h
fi
fi
@@ -18170,17 +10527,14 @@ fi
# Check for support of fts functions (readdir replacement)
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for fts" >&5
-echo $ECHO_N "checking for fts... $ECHO_C" >&6
-if test "${tcl_cv_api_fts+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fts" >&5
+printf %s "checking for fts... " >&6; }
+if test ${tcl_cv_api_fts+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/param.h>
@@ -18188,7 +10542,7 @@ cat >>conftest.$ac_ext <<_ACEOF
#include <fts.h>
int
-main ()
+main (void)
{
char*const p[2] = {"/", NULL};
@@ -18199,45 +10553,20 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_api_fts=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_api_fts=no
+else $as_nop
+ tcl_cv_api_fts=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_fts" >&5
-echo "${ECHO_T}$tcl_cv_api_fts" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_fts" >&5
+printf "%s\n" "$tcl_cv_api_fts" >&6; }
if test $tcl_cv_api_fts = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_FTS 1
-_ACEOF
+printf "%s\n" "#define HAVE_FTS 1" >>confdefs.h
fi
@@ -18248,328 +10577,37 @@ fi
#--------------------------------------------------------------------
+ ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_ioctl_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h
-for ac_header in sys/ioctl.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+ ac_fn_c_check_header_compile "$LINENO" "sys/filio.h" "ac_cv_header_sys_filio_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_filio_h" = xyes
+then :
+ printf "%s\n" "#define HAVE_SYS_FILIO_H 1" >>confdefs.h
fi
-done
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5
+printf %s "checking system version... " >&6; }
+if test ${tcl_cv_sys_version+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
-for ac_header in sys/filio.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking $ac_header usability" >&5
-echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking $ac_header presence" >&5
-echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <$ac_header>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
-echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- eval "$as_ac_Header=\$ac_header_preproc"
-fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
-
-fi
-
-done
-
-
- echo "$as_me:$LINENO: checking system version" >&5
-echo $ECHO_N "checking system version... $ECHO_C" >&6
-if test "${tcl_cv_sys_version+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-
- if test -f /usr/lib/NextStep/software_version; then
- tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
+ if test "${TEA_PLATFORM}" = "windows" ; then
+ tcl_cv_sys_version=windows
else
tcl_cv_sys_version=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
- { echo "$as_me:$LINENO: WARNING: can't find uname command" >&5
-echo "$as_me: WARNING: can't find uname command" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
+printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
- # Special check for weird MP-RAS system (uname returns weird
- # results, and the version is kept in special file).
-
- if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
- tcl_cv_sys_version=MP-RAS-`awk '{print $3}' /etc/.relid`
- fi
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
@@ -18580,58 +10618,46 @@ echo "$as_me: WARNING: can't find uname command" >&2;}
fi
fi
-echo "$as_me:$LINENO: result: $tcl_cv_sys_version" >&5
-echo "${ECHO_T}$tcl_cv_sys_version" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
+printf "%s\n" "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
- echo "$as_me:$LINENO: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
-echo $ECHO_N "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... $ECHO_C" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
+printf %s "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; }
case $system in
OSF*)
-cat >>confdefs.h <<\_ACEOF
-#define USE_FIONBIO 1
-_ACEOF
+printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h
- echo "$as_me:$LINENO: result: FIONBIO" >&5
-echo "${ECHO_T}FIONBIO" >&6
- ;;
- SunOS-4*)
-
-cat >>confdefs.h <<\_ACEOF
-#define USE_FIONBIO 1
-_ACEOF
-
- echo "$as_me:$LINENO: result: FIONBIO" >&5
-echo "${ECHO_T}FIONBIO" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5
+printf "%s\n" "FIONBIO" >&6; }
;;
*)
- echo "$as_me:$LINENO: result: O_NONBLOCK" >&5
-echo "${ECHO_T}O_NONBLOCK" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5
+printf "%s\n" "O_NONBLOCK" >&6; }
;;
esac
#------------------------------------------------------------------------
-echo "$as_me:$LINENO: checking whether to use dll unloading" >&5
-echo $ECHO_N "checking whether to use dll unloading... $ECHO_C" >&6
-# Check whether --enable-dll-unloading or --disable-dll-unloading was given.
-if test "${enable_dll_unloading+set}" = set; then
- enableval="$enable_dll_unloading"
- tcl_ok=$enableval
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use dll unloading" >&5
+printf %s "checking whether to use dll unloading... " >&6; }
+# Check whether --enable-dll-unloading was given.
+if test ${enable_dll_unloading+y}
+then :
+ enableval=$enable_dll_unloading; tcl_ok=$enableval
+else $as_nop
tcl_ok=yes
-fi;
+fi
+
if test $tcl_ok = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_UNLOAD_DLLS 1
-_ACEOF
+printf "%s\n" "#define TCL_UNLOAD_DLLS 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: result: $tcl_ok" >&5
-echo "${ECHO_T}$tcl_ok" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
+printf "%s\n" "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
@@ -18639,32 +10665,34 @@ echo "${ECHO_T}$tcl_ok" >&6
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
-echo "$as_me:$LINENO: checking for timezone data" >&5
-echo $ECHO_N "checking for timezone data... $ECHO_C" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for timezone data" >&5
+printf %s "checking for timezone data... " >&6; }
-# Check whether --with-tzdata or --without-tzdata was given.
-if test "${with_tzdata+set}" = set; then
- withval="$with_tzdata"
- tcl_ok=$withval
-else
+# Check whether --with-tzdata was given.
+if test ${with_tzdata+y}
+then :
+ withval=$with_tzdata; tcl_ok=$withval
+else $as_nop
tcl_ok=auto
-fi;
+fi
+
#
# Any directories that get added here must also be added to the
# search path in ::tcl::clock::Initialize (library/clock.tcl).
#
case $tcl_ok in
no)
- echo "$as_me:$LINENO: result: supplied by OS vendor" >&5
-echo "${ECHO_T}supplied by OS vendor" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: supplied by OS vendor" >&5
+printf "%s\n" "supplied by OS vendor" >&6; }
;;
yes)
# nothing to do here
;;
auto*)
- if test "${tcl_cv_dir_zoneinfo+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ if test ${tcl_cv_dir_zoneinfo+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
for dir in /usr/share/zoneinfo \
/usr/share/lib/zoneinfo \
@@ -18680,22 +10708,20 @@ fi
if test -n "$tcl_cv_dir_zoneinfo"; then
tcl_ok=no
- echo "$as_me:$LINENO: result: $dir" >&5
-echo "${ECHO_T}$dir" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $dir" >&5
+printf "%s\n" "$dir" >&6; }
else
tcl_ok=yes
fi
;;
*)
- { { echo "$as_me:$LINENO: error: invalid argument: $tcl_ok" >&5
-echo "$as_me: error: invalid argument: $tcl_ok" >&2;}
- { (exit 1); exit 1; }; }
+ as_fn_error $? "invalid argument: $tcl_ok" "$LINENO" 5
;;
esac
if test $tcl_ok = yes
then
- echo "$as_me:$LINENO: result: supplied by Tcl" >&5
-echo "${ECHO_T}supplied by Tcl" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: supplied by Tcl" >&5
+printf "%s\n" "supplied by Tcl" >&6; }
INSTALL_TZDATA=install-tzdata
fi
@@ -18703,167 +10729,33 @@ fi
# DTrace support
#--------------------------------------------------------------------
-# Check whether --enable-dtrace or --disable-dtrace was given.
-if test "${enable_dtrace+set}" = set; then
- enableval="$enable_dtrace"
- tcl_ok=$enableval
-else
+# Check whether --enable-dtrace was given.
+if test ${enable_dtrace+y}
+then :
+ enableval=$enable_dtrace; tcl_ok=$enableval
+else $as_nop
tcl_ok=no
-fi;
-if test $tcl_ok = yes; then
- if test "${ac_cv_header_sys_sdt_h+set}" = set; then
- echo "$as_me:$LINENO: checking for sys/sdt.h" >&5
-echo $ECHO_N "checking for sys/sdt.h... $ECHO_C" >&6
-if test "${ac_cv_header_sys_sdt_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_sys_sdt_h" >&5
-echo "${ECHO_T}$ac_cv_header_sys_sdt_h" >&6
-else
- # Is the header compilable?
-echo "$as_me:$LINENO: checking sys/sdt.h usability" >&5
-echo $ECHO_N "checking sys/sdt.h usability... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-#include <sys/sdt.h>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_header_compiler=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
-echo "${ECHO_T}$ac_header_compiler" >&6
-
-# Is the header present?
-echo "$as_me:$LINENO: checking sys/sdt.h presence" >&5
-echo $ECHO_N "checking sys/sdt.h presence... $ECHO_C" >&6
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <sys/sdt.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- ac_header_preproc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_header_preproc=no
-fi
-rm -f conftest.err conftest.$ac_ext
-echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
-echo "${ECHO_T}$ac_header_preproc" >&6
-
-# So? What about this header?
-case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
- yes:no: )
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: accepted by the compiler, rejected by the preprocessor!" >&5
-echo "$as_me: WARNING: sys/sdt.h: accepted by the compiler, rejected by the preprocessor!" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: proceeding with the compiler's result" >&5
-echo "$as_me: WARNING: sys/sdt.h: proceeding with the compiler's result" >&2;}
- ac_header_preproc=yes
- ;;
- no:yes:* )
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: present but cannot be compiled" >&5
-echo "$as_me: WARNING: sys/sdt.h: present but cannot be compiled" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: check for missing prerequisite headers?" >&5
-echo "$as_me: WARNING: sys/sdt.h: check for missing prerequisite headers?" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: see the Autoconf documentation" >&5
-echo "$as_me: WARNING: sys/sdt.h: see the Autoconf documentation" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: section \"Present But Cannot Be Compiled\"" >&5
-echo "$as_me: WARNING: sys/sdt.h: section \"Present But Cannot Be Compiled\"" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: proceeding with the preprocessor's result" >&5
-echo "$as_me: WARNING: sys/sdt.h: proceeding with the preprocessor's result" >&2;}
- { echo "$as_me:$LINENO: WARNING: sys/sdt.h: in the future, the compiler will take precedence" >&5
-echo "$as_me: WARNING: sys/sdt.h: in the future, the compiler will take precedence" >&2;}
- (
- cat <<\_ASBOX
-## ------------------------------ ##
-## Report this to the tcl lists. ##
-## ------------------------------ ##
-_ASBOX
- ) |
- sed "s/^/$as_me: WARNING: /" >&2
- ;;
-esac
-echo "$as_me:$LINENO: checking for sys/sdt.h" >&5
-echo $ECHO_N "checking for sys/sdt.h... $ECHO_C" >&6
-if test "${ac_cv_header_sys_sdt_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_header_sys_sdt_h=$ac_header_preproc
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_sys_sdt_h" >&5
-echo "${ECHO_T}$ac_cv_header_sys_sdt_h" >&6
-fi
-if test $ac_cv_header_sys_sdt_h = yes; then
+if test $tcl_ok = yes; then
+ ac_fn_c_check_header_compile "$LINENO" "sys/sdt.h" "ac_cv_header_sys_sdt_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_sdt_h" = xyes
+then :
tcl_ok=yes
-else
+else $as_nop
tcl_ok=no
fi
-
fi
if test $tcl_ok = yes; then
# Extract the first word of "dtrace", so it can be a program name with args.
set dummy dtrace; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_path_DTRACE+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_path_DTRACE+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
case $DTRACE in
[\\/]* | ?:[\\/]*)
ac_cv_path_DTRACE="$DTRACE" # Let the user override the test with a path.
@@ -18874,39 +10766,42 @@ as_dummy="$PATH:/usr/sbin"
for as_dir in $as_dummy
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
- ac_cv_path_DTRACE="$as_dir/$ac_word$ac_exec_ext"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ ac_cv_path_DTRACE="$as_dir$ac_word$ac_exec_ext"
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
;;
esac
fi
DTRACE=$ac_cv_path_DTRACE
-
if test -n "$DTRACE"; then
- echo "$as_me:$LINENO: result: $DTRACE" >&5
-echo "${ECHO_T}$DTRACE" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DTRACE" >&5
+printf "%s\n" "$DTRACE" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
test -z "$ac_cv_path_DTRACE" && tcl_ok=no
fi
-echo "$as_me:$LINENO: checking whether to enable DTrace support" >&5
-echo $ECHO_N "checking whether to enable DTrace support... $ECHO_C" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable DTrace support" >&5
+printf %s "checking whether to enable DTrace support... " >&6; }
MAKEFILE_SHELL='/bin/sh'
if test $tcl_ok = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define USE_DTRACE 1
-_ACEOF
+printf "%s\n" "#define USE_DTRACE 1" >>confdefs.h
DTRACE_SRC="\${DTRACE_SRC}"
DTRACE_HDR="\${DTRACE_HDR}"
@@ -18924,28 +10819,25 @@ _ACEOF
fi
fi
fi
-echo "$as_me:$LINENO: result: $tcl_ok" >&5
-echo "${ECHO_T}$tcl_ok" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
+printf "%s\n" "$tcl_ok" >&6; }
#--------------------------------------------------------------------
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking whether the cpuid instruction is usable" >&5
-echo $ECHO_N "checking whether the cpuid instruction is usable... $ECHO_C" >&6
-if test "${tcl_cv_cpuid+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the cpuid instruction is usable" >&5
+printf %s "checking whether the cpuid instruction is usable... " >&6; }
+if test ${tcl_cv_cpuid+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
int index,regsPtr[4];
@@ -18960,45 +10852,20 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_cpuid=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cpuid=no
+else $as_nop
+ tcl_cv_cpuid=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cpuid" >&5
-echo "${ECHO_T}$tcl_cv_cpuid" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cpuid" >&5
+printf "%s\n" "$tcl_cv_cpuid" >&6; }
if test $tcl_cv_cpuid = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_CPUID 1
-_ACEOF
+printf "%s\n" "#define HAVE_CPUID 1" >>confdefs.h
fi
@@ -19029,38 +10896,39 @@ HTML_DIR='$(DISTDIR)/html'
if test "`uname -s`" = "Darwin" ; then
if test "`uname -s`" = "Darwin" ; then
- echo "$as_me:$LINENO: checking how to package libraries" >&5
-echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6
- # Check whether --enable-framework or --disable-framework was given.
-if test "${enable_framework+set}" = set; then
- enableval="$enable_framework"
- enable_framework=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to package libraries" >&5
+printf %s "checking how to package libraries... " >&6; }
+ # Check whether --enable-framework was given.
+if test ${enable_framework+y}
+then :
+ enableval=$enable_framework; enable_framework=$enableval
+else $as_nop
enable_framework=no
-fi;
+fi
+
if test $enable_framework = yes; then
if test $SHARED_BUILD = 0; then
- { echo "$as_me:$LINENO: WARNING: Frameworks can only be built if --enable-shared is yes" >&5
-echo "$as_me: WARNING: Frameworks can only be built if --enable-shared is yes" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be built if --enable-shared is yes" >&5
+printf "%s\n" "$as_me: WARNING: Frameworks can only be built if --enable-shared is yes" >&2;}
enable_framework=no
fi
if test $tcl_corefoundation = no; then
- { echo "$as_me:$LINENO: WARNING: Frameworks can only be used when CoreFoundation is available" >&5
-echo "$as_me: WARNING: Frameworks can only be used when CoreFoundation is available" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be used when CoreFoundation is available" >&5
+printf "%s\n" "$as_me: WARNING: Frameworks can only be used when CoreFoundation is available" >&2;}
enable_framework=no
fi
fi
if test $enable_framework = yes; then
- echo "$as_me:$LINENO: result: framework" >&5
-echo "${ECHO_T}framework" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: framework" >&5
+printf "%s\n" "framework" >&6; }
FRAMEWORK_BUILD=1
else
if test $SHARED_BUILD = 1; then
- echo "$as_me:$LINENO: result: shared library" >&5
-echo "${ECHO_T}shared library" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared library" >&5
+printf "%s\n" "shared library" >&6; }
else
- echo "$as_me:$LINENO: result: static library" >&5
-echo "${ECHO_T}static library" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static library" >&5
+printf "%s\n" "static library" >&6; }
fi
FRAMEWORK_BUILD=0
fi
@@ -19071,21 +10939,18 @@ echo "${ECHO_T}static library" >&6
echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
- EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic'
- ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in"
+ ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in"
TCL_YEAR="`date +%Y`"
fi
if test "$FRAMEWORK_BUILD" = "1" ; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_FRAMEWORK 1
-_ACEOF
+printf "%s\n" "#define TCL_FRAMEWORK 1" >>confdefs.h
# Construct a fake local framework structure to make linking with
# '-framework Tcl' and running of tcltest work
- ac_config_commands="$ac_config_commands Tcl.framework"
+ ac_config_commands="$ac_config_commands Tcl.framework"
LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
# default install directory for bundled packages
@@ -19136,6 +11001,202 @@ eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
VERSION=${TCL_VERSION}
#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+# Check whether --enable-zipfs was given.
+if test ${enable_zipfs+y}
+then :
+ enableval=$enable_zipfs; tcl_ok=$enableval
+else $as_nop
+ tcl_ok=yes
+fi
+
+if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then
+ #
+ # Find a native compiler
+ #
+ # Put a plausible default for CC_FOR_BUILD in Makefile.
+ if test -z "$CC_FOR_BUILD"; then
+ if test "x$cross_compiling" = "xno"; then
+ CC_FOR_BUILD='$(CC)'
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
+printf %s "checking for gcc... " >&6; }
+ if test ${ac_cv_path_cc+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/gcc 2> /dev/null` \
+ `ls -r $dir/gcc 2> /dev/null` ; do
+ if test x"$ac_cv_path_cc" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_cc=$j
+ break
+ fi
+ fi
+ done
+ done
+
+fi
+
+ fi
+ fi
+
+ # Also set EXEEXT_FOR_BUILD.
+ if test "x$cross_compiling" = "xno"; then
+ EXEEXT_FOR_BUILD='$(EXEEXT)'
+ OBJEXT_FOR_BUILD='$(OBJEXT)'
+ else
+ OBJEXT_FOR_BUILD='.no'
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
+printf %s "checking for build system executable suffix... " >&6; }
+if test ${bfd_cv_build_exeext+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ rm -f conftest*
+ echo 'int main () { return 0; }' > conftest.c
+ bfd_cv_build_exeext=
+ ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
+ for file in conftest.*; do
+ case $file in
+ *.c | *.o | *.obj | *.ilk | *.pdb) ;;
+ *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
+ esac
+ done
+ rm -f conftest*
+ test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
+printf "%s\n" "$bfd_cv_build_exeext" >&6; }
+ EXEEXT_FOR_BUILD=""
+ test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
+ fi
+
+ #
+ # Find a native zip implementation
+ #
+
+ MACHER_PROG=""
+ ZIP_PROG=""
+ ZIP_PROG_OPTIONS=""
+ ZIP_PROG_VFSSEARCH=""
+ ZIP_INSTALL_OBJS=""
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for macher" >&5
+printf %s "checking for macher... " >&6; }
+ if test ${ac_cv_path_macher+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/macher 2> /dev/null` \
+ `ls -r $dir/macher 2> /dev/null` ; do
+ if test x"$ac_cv_path_macher" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_macher=$j
+ break
+ fi
+ fi
+ done
+ done
+
+fi
+
+ if test -f "$ac_cv_path_macher" ; then
+ MACHER_PROG="$ac_cv_path_macher"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MACHER_PROG" >&5
+printf "%s\n" "$MACHER_PROG" >&6; }
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found macher in environment" >&5
+printf "%s\n" "Found macher in environment" >&6; }
+ fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
+printf %s "checking for zip... " >&6; }
+ if test ${ac_cv_path_zip+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/zip 2> /dev/null` \
+ `ls -r $dir/zip 2> /dev/null` ; do
+ if test x"$ac_cv_path_zip" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_zip=$j
+ break
+ fi
+ fi
+ done
+ done
+
+fi
+
+ if test -f "$ac_cv_path_zip" ; then
+ ZIP_PROG="$ac_cv_path_zip"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
+printf "%s\n" "$ZIP_PROG" >&6; }
+ ZIP_PROG_OPTIONS="-rq"
+ ZIP_PROG_VFSSEARCH="*"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
+printf "%s\n" "Found INFO Zip in environment" >&6; }
+ # Use standard arguments for zip
+ else
+ # It is not an error if an installed version of Zip can't be located.
+ # We can use the locally distributed minizip instead
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG_OPTIONS="-o -r"
+ ZIP_PROG_VFSSEARCH="*"
+ ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5
+printf "%s\n" "No zip found on PATH. Building minizip" >&6; }
+ fi
+
+
+
+
+
+
+ ZIPFS_BUILD=1
+ TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip
+else
+ ZIPFS_BUILD=0
+ TCL_ZIP_FILE=
+fi
+# Do checking message here to not mess up interleaved configure output
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
+printf %s "checking for building with zipfs... " >&6; }
+if test "${ZIPFS_BUILD}" = 1; then
+ if test "${SHARED_BUILD}" = 0; then
+ ZIPFS_BUILD=2;
+
+printf "%s\n" "#define ZIPFS_BUILD 2" >>confdefs.h
+
+ else
+
+printf "%s\n" "#define ZIPFS_BUILD 1" >>confdefs.h
+\
+ fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
+else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+INSTALL_LIBRARIES=install-libraries
+INSTALL_MSGS=install-msgs
+fi
+
+
+
+
+
+
+#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
@@ -19245,7 +11306,8 @@ TCL_SHARED_BUILD=${SHARED_BUILD}
- ac_config_files="$ac_config_files Makefile:../unix/Makefile.in dltest/Makefile:../unix/dltest/Makefile.in tclConfig.sh:../unix/tclConfig.sh.in tcl.pc:../unix/tcl.pc.in"
+
+ac_config_files="$ac_config_files Makefile:../unix/Makefile.in dltest/Makefile:../unix/dltest/Makefile.in tclConfig.sh:../unix/tclConfig.sh.in tcl.pc:../unix/tcl.pc.in"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
@@ -19265,39 +11327,70 @@ _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.
+# So, we kill variables containing newlines.
# 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.
-{
+(
+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
+ *) { eval $ac_var=; unset $ac_var;} ;;
+ esac ;;
+ esac
+ done
+
(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 \).
+ case $as_nl`(ac_space=' '; set) 2>&1` in #(
+ *${as_nl}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"
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
- esac;
-} |
+ esac |
+ sort
+) |
sed '
+ /^ac_cv_env_/b end
t clear
- : clear
- s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
+ :clear
+ s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/
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
+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
+ :end' >>confcache
+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
+ if test -w "$cache_file"; then
+ if test "x$cache_file" != "x/dev/null"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
+printf "%s\n" "$as_me: updating cache $cache_file" >&6;}
+ if test ! -f "$cache_file" || test -h "$cache_file"; then
+ cat confcache >"$cache_file"
+ else
+ case $cache_file in #(
+ */* | ?:*)
+ mv -f confcache "$cache_file"$$ &&
+ mv -f "$cache_file"$$ "$cache_file" ;; #(
+ *)
+ mv -f confcache "$cache_file" ;;
+ esac
+ fi
+ fi
else
- echo "not updating unwritable cache $cache_file"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
+printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
@@ -19306,63 +11399,56 @@ 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,
+# take arguments), then branch to the quote section. Otherwise,
# look for a macro that doesn't take arguments.
-cat >confdef2opt.sed <<\_ACEOF
+ac_script='
+:mline
+/\\$/{
+ N
+ s,\\\n,,
+ b mline
+}
t clear
-: clear
-s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
+:clear
+s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
t quote
-s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
+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
+b any
+:quote
+s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g
+s/\[/\\&/g
+s/\]/\\&/g
+s/\$/$$/g
+H
+:any
+${
+ g
+ s/^\n//
+ s/\n/ /g
+ p
+}
+'
+DEFS=`sed -n "$ac_script" confdefs.h`
CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""
-: ${CONFIG_STATUS=./config.status}
+
+: "${CONFIG_STATUS=./config.status}"
+ac_write_fail=0
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
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
+printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;}
+as_write_fail=0
+cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1
#! $SHELL
# Generated by $as_me.
# Run this file to recreate the current configuration.
@@ -19372,81 +11458,236 @@ cat >$CONFIG_STATUS <<_ACEOF
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
+SHELL=\${CONFIG_SHELL-$SHELL}
+export SHELL
+_ASEOF
+cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1
+## -------------------- ##
+## M4sh Initialization. ##
+## -------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+as_nop=:
+if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
+then :
emulate sh
NULLCMD=:
- # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # Pre-4.2 versions of Zsh do 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
+ setopt NO_GLOB_SUBST
+else $as_nop
+ case `(set -o) 2>/dev/null` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
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
+# Reset variables that may have inherited troublesome values from
+# the environment.
+
+# IFS needs to be set, to space, tab, and newline, in precisely that order.
+# (If _AS_PATH_WALK were called with IFS unset, it would have the
+# side effect of setting IFS to empty, thus disabling word splitting.)
+# Quoting is to prevent editors from complaining about space-tab.
+as_nl='
+'
+export as_nl
+IFS=" "" $as_nl"
+
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
+# Ensure predictable behavior from utilities with locale-dependent output.
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# We cannot yet rely on "unset" to work, but we need these variables
+# to be unset--not just set to an empty or harmless value--now, to
+# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
+# also avoids known problems related to "unset" and subshell syntax
+# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
+for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
+do eval test \${$as_var+y} \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
+
+# Ensure that fds 0, 1, and 2 are open.
+if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
+if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
+if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
+
+# The user is always right.
+if ${PATH_SEPARATOR+false} :; then
+ PATH_SEPARATOR=:
+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
+ PATH_SEPARATOR=';'
+ }
+fi
+
+
+# Find who we are. Look in the path if we contain no directory separator.
+as_myself=
+case $0 in #((
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
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
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ test -r "$as_dir$0" && as_myself=$as_dir$0 && break
+ done
+IFS=$as_save_IFS
+
+ ;;
+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
+ printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+
+
+# as_fn_error STATUS ERROR [LINENO LOG_FD]
+# ----------------------------------------
+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
+# script with STATUS, using 1 if that was 0.
+as_fn_error ()
+{
+ as_status=$1; test $as_status -eq 0 && as_status=1
+ if test "$4"; then
+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
-done
+ printf "%s\n" "$as_me: error: $2" >&2
+ as_fn_exit $as_status
+} # as_fn_error
+
+
+
+# as_fn_set_status STATUS
+# -----------------------
+# Set $? to STATUS, without forking.
+as_fn_set_status ()
+{
+ return $1
+} # as_fn_set_status
+
+# as_fn_exit STATUS
+# -----------------
+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
+as_fn_exit ()
+{
+ set +e
+ as_fn_set_status $1
+ exit $1
+} # as_fn_exit
+
+# as_fn_unset VAR
+# ---------------
+# Portably unset VAR.
+as_fn_unset ()
+{
+ { eval $1=; unset $1;}
+}
+as_unset=as_fn_unset
+
+# as_fn_append VAR VALUE
+# ----------------------
+# Append the text in VALUE to the end of the definition contained in VAR. Take
+# advantage of any shell optimizations that allow amortized linear growth over
+# repeated appends, instead of the typical quadratic growth present in naive
+# implementations.
+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
+then :
+ eval 'as_fn_append ()
+ {
+ eval $1+=\$2
+ }'
+else $as_nop
+ as_fn_append ()
+ {
+ eval $1=\$$1\$2
+ }
+fi # as_fn_append
+
+# as_fn_arith ARG...
+# ------------------
+# Perform arithmetic evaluation on the ARGs, and store the result in the
+# global $as_val. Take advantage of shells that can avoid forks. The arguments
+# must be portable across $(()) and expr.
+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
+then :
+ eval 'as_fn_arith ()
+ {
+ as_val=$(( $* ))
+ }'
+else $as_nop
+ as_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
-if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
-# Name of the executable.
-as_me=`$as_basename "$0" ||
+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'`
-
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" 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'
@@ -19454,148 +11695,121 @@ 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= ;;
+# Determine whether it's possible to make 'echo' print without a newline.
+# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
+# for compatibility with existing Makefiles.
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in #(((((
+-n*)
+ case `echo 'xy\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ xy) ECHO_C='\c';;
+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
+ ECHO_T=' ';;
+ esac;;
+*)
+ ECHO_N='-n';;
esac
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
+# For backward compatibility with old third-party macros, we provide
+# the shell variables $as_echo and $as_echo_n. New code should use
+# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
+as_echo='printf %s\n'
+as_echo_n='printf %s'
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
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
+fi
+if (echo >conf$$.file) 2>/dev/null; then
+ if ln -s conf$$.file conf$$ 2>/dev/null; then
as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -pR'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -pR'
+ elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+ else
+ as_ln_s='cp -pR'
fi
-elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
-rm -f conf$$ conf$$.exe conf$$.file
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+
+# as_fn_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
+
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || eval $as_mkdir_p || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
+
+} # as_fn_mkdir_p
if mkdir -p . 2>/dev/null; then
- as_mkdir_p=:
+ as_mkdir_p='mkdir -p "$as_dir"'
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
-as_executable_p="test -f"
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# 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'"
@@ -19604,31 +11818,20 @@ as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
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
+## ----------------------------------- ##
+## Main body of $CONFIG_STATUS script. ##
+## ----------------------------------- ##
+_ASEOF
+test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# Save the log message, 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 tcl $as_me 8.6, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+# values after options handling.
+ac_log="
+This file was extended by tcl $as_me 8.7, which was
+generated by GNU Autoconf 2.71. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
@@ -19636,43 +11839,41 @@ generated by GNU Autoconf 2.59. Invocation command line was
CONFIG_COMMANDS = $CONFIG_COMMANDS
$ $0 $@
-_CSEOF
-echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5
-echo >&5
+on `(hostname || uname -n) 2>/dev/null | sed 1q`
+"
+
_ACEOF
-# Files that config.status was made for.
-if test -n "$ac_config_files"; then
- echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS
-fi
+case $ac_config_files in *"
+"*) set x $ac_config_files; shift; ac_config_files=$*;;
+esac
-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_write_fail=1
+# Files that config.status was made for.
+config_files="$ac_config_files"
+config_commands="$ac_config_commands"
-cat >>$CONFIG_STATUS <<\_ACEOF
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
ac_cs_usage="\
-\`$as_me' instantiates files from templates according to the
-current configuration.
+\`$as_me' instantiates files and other configuration actions
+from templates according to the current configuration. Unless the files
+and actions are specified as TAGs, all are instantiated by default.
-Usage: $0 [OPTIONS] [FILE]...
+Usage: $0 [OPTION]... [TAG]...
-h, --help print this help, then exit
- -V, --version print version number, then exit
- -q, --quiet do not print progress messages
+ -V, --version print version number and configuration settings, then exit
+ --config print configuration, then exit
+ -q, --quiet, --silent
+ 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
+ --file=FILE[:TEMPLATE]
+ instantiate the configuration file FILE
Configuration files:
$config_files
@@ -19680,83 +11881,80 @@ $config_files
Configuration commands:
$config_commands
-Report bugs to <bug-autoconf@gnu.org>."
-_ACEOF
+Report bugs to the package provider."
-cat >>$CONFIG_STATUS <<_ACEOF
+_ACEOF
+ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"`
+ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"`
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_cs_config='$ac_cs_config_escaped'
ac_cs_version="\\
-tcl config.status 8.6
-configured by $0, generated by GNU Autoconf 2.59,
- with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"
+tcl config.status 8.7
+configured by $0, generated by GNU Autoconf 2.71,
+ with options \\"\$ac_cs_config\\"
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2021 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
+
+ac_pwd='$ac_pwd'
+srcdir='$srcdir'
+test -n "\$AWK" || AWK=awk
_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.
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# The default lists apply if the user does not specify any file.
ac_need_defaults=:
while test $# != 0
do
case $1 in
- --*=*)
- ac_option=`expr "x$1" : 'x\([^=]*\)='`
- ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'`
+ --*=?*)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
ac_shift=:
;;
- -*)
+ --*=)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=
+ 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 )
+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )
+ printf "%s\n" "$ac_cs_version"; exit ;;
+ --config | --confi | --conf | --con | --co | --c )
+ printf "%s\n" "$ac_cs_config"; exit ;;
+ --debug | --debu | --deb | --de | --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"
+ case $ac_optarg in
+ *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ '') as_fn_error $? "missing file argument" ;;
+ esac
+ as_fn_append CONFIG_FILES " '$ac_optarg'"
ac_need_defaults=false;;
+ --he | --h | --help | --hel | -h )
+ printf "%s\n" "$ac_cs_usage"; exit ;;
-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; }; } ;;
+ -*) as_fn_error $? "unrecognized option: \`$1'
+Try \`$0 --help' for more information." ;;
- *) ac_config_targets="$ac_config_targets $1" ;;
+ *) as_fn_append ac_config_targets " $1"
+ ac_need_defaults=false ;;
esac
shift
@@ -19770,582 +11968,486 @@ if $ac_cs_silent; then
fi
_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
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
+ set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+ shift
+ \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6
+ CONFIG_SHELL='$SHELL'
+ export CONFIG_SHELL
+ exec "\$@"
fi
_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+exec 5>>config.log
+{
+ echo
+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
+## Running $as_me. ##
+_ASBOX
+ printf "%s\n" "$ac_log"
+} >&5
-cat >>$CONFIG_STATUS <<_ACEOF
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
#
-# INIT-COMMANDS section.
+# INIT-COMMANDS
#
-
VERSION=${TCL_VERSION}
_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
-
-cat >>$CONFIG_STATUS <<\_ACEOF
+# Handling of arguments.
for ac_config_target in $ac_config_targets
do
- case "$ac_config_target" in
- # Handling of arguments.
- "Tcl-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;;
- "Tclsh-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" ;;
- "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile:../unix/Makefile.in" ;;
- "dltest/Makefile" ) CONFIG_FILES="$CONFIG_FILES dltest/Makefile:../unix/dltest/Makefile.in" ;;
- "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh:../unix/tclConfig.sh.in" ;;
- "tcl.pc" ) CONFIG_FILES="$CONFIG_FILES tcl.pc:../unix/tcl.pc.in" ;;
- "Tcl.framework" ) CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;;
- *) { { 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; }; };;
+ case $ac_config_target in
+ "Tcl-Info.plist") CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;;
+ "Tclsh-Info.plist") CONFIG_FILES="$CONFIG_FILES Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" ;;
+ "Tcl.framework") CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;;
+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile:../unix/Makefile.in" ;;
+ "dltest/Makefile") CONFIG_FILES="$CONFIG_FILES dltest/Makefile:../unix/dltest/Makefile.in" ;;
+ "tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh:../unix/tclConfig.sh.in" ;;
+ "tcl.pc") CONFIG_FILES="$CONFIG_FILES tcl.pc:../unix/tcl.pc.in" ;;
+
+ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
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
- test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands
+ test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files
+ test ${CONFIG_COMMANDS+y} || CONFIG_COMMANDS=$config_commands
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,
+# simply because there is no reason against having 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.
+# Hook for its removal unless debugging.
+# Note that there is a small window in which the directory will not be cleaned:
+# after its creation but before its name has been assigned to `$tmp'.
$debug ||
{
- trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0
- trap '{ (exit 1); exit 1; }' 1 2 13 15
+ tmp= ac_tmp=
+ trap 'exit_status=$?
+ : "${ac_tmp:=$tmp}"
+ { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status
+' 0
+ trap 'as_fn_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=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
+ test -d "$tmp"
} ||
{
- tmp=./confstat$$-$RANDOM
- (umask 077 && mkdir $tmp)
-} ||
+ tmp=./conf$$-$RANDOM
+ (umask 077 && mkdir "$tmp")
+} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5
+ac_tmp=$tmp
+
+# Set up the scripts for CONFIG_FILES section.
+# No need to generate them if there are no CONFIG_FILES.
+# This happens for instance with `./config.status config.h'.
+if test -n "$CONFIG_FILES"; then
+
+
+ac_cr=`echo X | tr X '\015'`
+# On cygwin, bash can eat \r inside `` if the user requested igncr.
+# But we know of no other shell where ac_cr would be empty at this
+# point, so we can use a bashism as a fallback.
+if test "x$ac_cr" = x; then
+ eval ac_cr=\$\'\\r\'
+fi
+ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null`
+if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then
+ ac_cs_awk_cr='\\r'
+else
+ ac_cs_awk_cr=$ac_cr
+fi
+
+echo 'BEGIN {' >"$ac_tmp/subs1.awk" &&
+_ACEOF
+
+
{
- echo "$me: cannot create a temporary directory in ." >&2
- { (exit 1); exit 1; }
+ echo "cat >conf$$subs.awk <<_ACEOF" &&
+ echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' &&
+ echo "_ACEOF"
+} >conf$$subs.sh ||
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'`
+ac_delim='%!_!# '
+for ac_last_try in false false false false false :; do
+ . ./conf$$subs.sh ||
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+
+ ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X`
+ if test $ac_delim_n = $ac_delim_num; then
+ break
+ elif $ac_last_try; then
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+ else
+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
+ fi
+done
+rm -f conf$$subs.sh
+
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK &&
+_ACEOF
+sed -n '
+h
+s/^/S["/; s/!.*/"]=/
+p
+g
+s/^[^!]*!//
+:repl
+t repl
+s/'"$ac_delim"'$//
+t delim
+:nl
+h
+s/\(.\{148\}\)..*/\1/
+t more1
+s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/
+p
+n
+b repl
+:more1
+s/["\\]/\\&/g; s/^/"/; s/$/"\\/
+p
+g
+s/.\{148\}//
+t nl
+:delim
+h
+s/\(.\{148\}\)..*/\1/
+t more2
+s/["\\]/\\&/g; s/^/"/; s/$/"/
+p
+b
+:more2
+s/["\\]/\\&/g; s/^/"/; s/$/"\\/
+p
+g
+s/.\{148\}//
+t delim
+' <conf$$subs.awk | sed '
+/^[^""]/{
+ N
+ s/\n//
+}
+' >>$CONFIG_STATUS || ac_write_fail=1
+rm -f conf$$subs.awk
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+_ACAWK
+cat >>"\$ac_tmp/subs1.awk" <<_ACAWK &&
+ for (key in S) S_is_set[key] = 1
+ FS = ""
+
+}
+{
+ line = $ 0
+ nfields = split(line, field, "@")
+ substed = 0
+ len = length(field[1])
+ for (i = 2; i < nfields; i++) {
+ key = field[i]
+ keylen = length(key)
+ if (S_is_set[key]) {
+ value = S[key]
+ line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3)
+ len += length(value) + length(field[++i])
+ substed = 1
+ } else
+ len += 1 + keylen
+ }
+
+ print line
}
+_ACAWK
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then
+ sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g"
+else
+ cat
+fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \
+ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5
_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
+# VPATH may cause trouble with some makes, so we remove sole $(srcdir),
+# ${srcdir} and @srcdir@ entries 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[ ]*=[ ]*/{
+h
+s///
+s/^/:/
+s/[ ]*$/:/
+s/:\$(srcdir):/:/g
+s/:\${srcdir}:/:/g
+s/:@srcdir@:/:/g
+s/^:*//
+s/:*$//
+x
+s/\(=[ ]*\).*/\1/
+G
+s/\n//
+s/^[^=]*=[ ]*$//
+}'
+fi
-#
-# CONFIG_FILES section.
-#
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+fi # test -n "$CONFIG_FILES"
-# 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,@MAN_FLAGS@,$MAN_FLAGS,;t t
-s,@CC@,$CC,;t t
-s,@CFLAGS@,$CFLAGS,;t t
-s,@LDFLAGS@,$LDFLAGS,;t t
-s,@CPPFLAGS@,$CPPFLAGS,;t t
-s,@ac_ct_CC@,$ac_ct_CC,;t t
-s,@EXEEXT@,$EXEEXT,;t t
-s,@OBJEXT@,$OBJEXT,;t t
-s,@CPP@,$CPP,;t t
-s,@EGREP@,$EGREP,;t t
-s,@TCL_THREADS@,$TCL_THREADS,;t t
-s,@SHARED_BUILD@,$SHARED_BUILD,;t t
-s,@TCLSH_PROG@,$TCLSH_PROG,;t t
-s,@ZLIB_OBJS@,$ZLIB_OBJS,;t t
-s,@ZLIB_SRCS@,$ZLIB_SRCS,;t t
-s,@ZLIB_INCLUDE@,$ZLIB_INCLUDE,;t t
-s,@RANLIB@,$RANLIB,;t t
-s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t
-s,@AR@,$AR,;t t
-s,@ac_ct_AR@,$ac_ct_AR,;t t
-s,@LIBOBJS@,$LIBOBJS,;t t
-s,@TCL_LIBS@,$TCL_LIBS,;t t
-s,@DL_LIBS@,$DL_LIBS,;t t
-s,@DL_OBJS@,$DL_OBJS,;t t
-s,@PLAT_OBJS@,$PLAT_OBJS,;t t
-s,@PLAT_SRCS@,$PLAT_SRCS,;t t
-s,@LDAIX_SRC@,$LDAIX_SRC,;t t
-s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t
-s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t
-s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t
-s,@CFLAGS_NOLTO@,$CFLAGS_NOLTO,;t t
-s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t
-s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t
-s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t
-s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t
-s,@STLIB_LD@,$STLIB_LD,;t t
-s,@SHLIB_LD@,$SHLIB_LD,;t t
-s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t
-s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t
-s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t
-s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t
-s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t
-s,@MAKE_LIB@,$MAKE_LIB,;t t
-s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t
-s,@INSTALL_LIB@,$INSTALL_LIB,;t t
-s,@DLL_INSTALL_DIR@,$DLL_INSTALL_DIR,;t t
-s,@INSTALL_STUB_LIB@,$INSTALL_STUB_LIB,;t t
-s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t
-s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t
-s,@DTRACE@,$DTRACE,;t t
-s,@TCL_VERSION@,$TCL_VERSION,;t t
-s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t
-s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t
-s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t
-s,@TCL_YEAR@,$TCL_YEAR,;t t
-s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t
-s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t
-s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t
-s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t
-s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t
-s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t
-s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t
-s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t
-s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t
-s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t
-s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t
-s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t
-s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t
-s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t
-s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t
-s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t
-s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t
-s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t
-s,@TCL_SHARED_LIB_SUFFIX@,$TCL_SHARED_LIB_SUFFIX,;t t
-s,@TCL_UNSHARED_LIB_SUFFIX@,$TCL_UNSHARED_LIB_SUFFIX,;t t
-s,@TCL_HAS_LONGLONG@,$TCL_HAS_LONGLONG,;t t
-s,@INSTALL_TZDATA@,$INSTALL_TZDATA,;t t
-s,@DTRACE_SRC@,$DTRACE_SRC,;t t
-s,@DTRACE_HDR@,$DTRACE_HDR,;t t
-s,@DTRACE_OBJ@,$DTRACE_OBJ,;t t
-s,@MAKEFILE_SHELL@,$MAKEFILE_SHELL,;t t
-s,@BUILD_DLTEST@,$BUILD_DLTEST,;t t
-s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t
-s,@TCL_MODULE_PATH@,$TCL_MODULE_PATH,;t t
-s,@TCL_LIBRARY@,$TCL_LIBRARY,;t t
-s,@PRIVATE_INCLUDE_DIR@,$PRIVATE_INCLUDE_DIR,;t t
-s,@HTML_DIR@,$HTML_DIR,;t t
-s,@PACKAGE_DIR@,$PACKAGE_DIR,;t t
-s,@EXTRA_CC_SWITCHES@,$EXTRA_CC_SWITCHES,;t t
-s,@EXTRA_APP_CC_SWITCHES@,$EXTRA_APP_CC_SWITCHES,;t t
-s,@EXTRA_INSTALL@,$EXTRA_INSTALL,;t t
-s,@EXTRA_INSTALL_BINARIES@,$EXTRA_INSTALL_BINARIES,;t t
-s,@EXTRA_BUILD_HTML@,$EXTRA_BUILD_HTML,;t t
-s,@EXTRA_TCLSH_LIBS@,$EXTRA_TCLSH_LIBS,;t t
-s,@DLTEST_LD@,$DLTEST_LD,;t t
-s,@DLTEST_SUFFIX@,$DLTEST_SUFFIX,;t t
-CEOF
-_ACEOF
+eval set X " :F $CONFIG_FILES :C $CONFIG_COMMANDS"
+shift
+for ac_tag
+do
+ case $ac_tag in
+ :[FHLC]) ac_mode=$ac_tag; continue;;
+ esac
+ case $ac_mode$ac_tag in
+ :[FHL]*:*);;
+ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;
+ :[FH]-) ac_tag=-:-;;
+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
+ esac
+ ac_save_IFS=$IFS
+ IFS=:
+ set x $ac_tag
+ IFS=$ac_save_IFS
+ shift
+ ac_file=$1
+ shift
- 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`
+ case $ac_mode in
+ :L) ac_source=$1;;
+ :[FH])
+ ac_file_inputs=
+ for ac_f
+ do
+ case $ac_f in
+ -) ac_f="$ac_tmp/stdin";;
+ *) # Look for the file first in the build tree, then in the source tree
+ # (if the path is not absolute). The absolute path cannot be DOS-style,
+ # because $ac_f cannot contain `:'.
+ test -f "$ac_f" ||
+ case $ac_f in
+ [\\/$]*) false;;
+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
+ esac ||
+ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
+ esac
+ case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
+ as_fn_append ac_file_inputs " '$ac_f'"
+ done
+
+ # 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. */
+ configure_input='Generated from '`
+ printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
+ `' by configure.'
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
+printf "%s\n" "$as_me: creating $ac_file" >&6;}
fi
- done
- if test -z "$ac_sed_cmds"; then
- ac_sed_cmds=cat
- fi
-fi # test -n "$CONFIG_FILES"
+ # Neutralize special characters interpreted by sed in replacement strings.
+ case $configure_input in #(
+ *\&* | *\|* | *\\* )
+ ac_sed_conf_input=`printf "%s\n" "$configure_input" |
+ sed 's/[\\\\&|]/\\\\&/g'`;; #(
+ *) ac_sed_conf_input=$configure_input;;
+ esac
-_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 ;;
+ case $ac_tag in
+ *:-:* | *:-) cat >"$ac_tmp/stdin" \
+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;
+ esac
+ ;;
esac
- # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
- ac_dir=`(dirname "$ac_file") 2>/dev/null ||
+ ac_dir=`$as_dirname -- "$ac_file" ||
$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; }; }; }
-
+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$ac_file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ as_dir="$ac_dir"; as_fn_mkdir_p
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 "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
case $srcdir in
- .) # No --srcdir option. We are building in place.
+ .) # 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_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
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 ;;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$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;;
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+
+ case $ac_mode in
+ :F)
+ #
+ # CONFIG_FILE
+ #
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# If the template does not know about datarootdir, expand it.
+# FIXME: This hack should be removed a few years after 2.60.
+ac_datarootdir_hack=; ac_datarootdir_seen=
+ac_sed_dataroot='
+/datarootdir/ {
+ p
+ q
+}
+/@datadir@/p
+/@docdir@/p
+/@infodir@/p
+/@localedir@/p
+/@mandir@/p'
+case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in
+*datarootdir*) ac_datarootdir_seen=yes;;
+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ ac_datarootdir_hack='
+ s&@datadir@&$datadir&g
+ s&@docdir@&$docdir&g
+ s&@infodir@&$infodir&g
+ s&@localedir@&$localedir&g
+ s&@mandir@&$mandir&g
+ s&\\\${datarootdir}&$datarootdir&g' ;;
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
+
+# Neutralize VPATH when `$srcdir' = `.'.
+# Shell code in configure.ac might set extrasub.
+# FIXME: do we really want to maintain this feature?
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_sed_extra="$ac_vpsub
$extrasub
_ACEOF
-cat >>$CONFIG_STATUS <<\_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
: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
-
-#
-# CONFIG_COMMANDS section.
-#
-for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue
- ac_dest=`echo "$ac_file" | sed 's,:.*,,'`
- ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'`
- ac_dir=`(dirname "$ac_dest") 2>/dev/null ||
-$as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
- X"$ac_dest" : 'X\(//\)[^/]' \| \
- X"$ac_dest" : 'X\(//\)$' \| \
- X"$ac_dest" : 'X\(/\)' \| \
- . : '\(.\)' 2>/dev/null ||
-echo X"$ac_dest" |
- 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
+s|@configure_input@|$ac_sed_conf_input|;t t
+s&@top_builddir@&$ac_top_builddir_sub&;t t
+s&@top_build_prefix@&$ac_top_build_prefix&;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&@abs_top_builddir@&$ac_abs_top_builddir&;t t
+$ac_datarootdir_hack
+"
+eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
+ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
+
+test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
+ { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
+ "$ac_tmp/out"`; test -z "$ac_out"; } &&
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined" >&5
+printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined" >&2;}
+
+ rm -f "$ac_tmp/stdin"
+ case $ac_file in
+ -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;
+ *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;
+ esac \
+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5
+ ;;
-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
+ :C) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5
+printf "%s\n" "$as_me: executing $ac_file commands" >&6;}
+ ;;
+ esac
- { echo "$as_me:$LINENO: executing $ac_dest commands" >&5
-echo "$as_me: executing $ac_dest commands" >&6;}
- case $ac_dest in
- Tcl.framework ) n=Tcl &&
+ case $ac_file$ac_mode in
+ "Tcl.framework":C) n=Tcl &&
f=$n.framework && v=Versions/$VERSION &&
rm -rf $f && mkdir -p $f/$v/Resources &&
ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v &&
ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist &&
unset n f v
;;
+
esac
-done
-_ACEOF
+done # for ac_tag
-cat >>$CONFIG_STATUS <<\_ACEOF
-{ (exit 0); exit 0; }
+as_fn_exit 0
_ACEOF
-chmod +x $CONFIG_STATUS
ac_clean_files=$ac_clean_files_save
+test $ac_write_fail = 0 ||
+ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5
+
# configure is writing to config.log, and then calls config.status.
# config.status does its own redirection, appending to config.log.
@@ -20365,7 +12467,12 @@ if test "$no_create" != yes; then
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; }
+ $ac_cs_success || as_fn_exit 1
fi
+if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
+printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
+fi
+
diff --git a/unix/configure.in b/unix/configure.ac
index 14922a6..60e7a62 100644
--- a/unix/configure.in
+++ b/unix/configure.ac
@@ -3,8 +3,8 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
-AC_INIT([tcl],[8.6])
-AC_PREREQ([2.59])
+AC_INIT([tcl],[8.7])
+AC_PREREQ([2.69])
dnl This is only used when included from macosx/configure.ac
m4_ifdef([SC_USE_CONFIG_HEADERS], [
@@ -23,10 +23,10 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [
#endif /* _TCLCONFIG */])
])
-TCL_VERSION=8.6
+TCL_VERSION=8.7
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL=".13"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a6"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
@@ -87,10 +87,11 @@ fi
AC_PROG_CC
AC_C_INLINE
+
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
-# - stdlib.h doesn't define strtol, strtoul, or
-# strtod in some versions of SunOS
+# - stdlib.h doesn't define strtol or strtoul in some versions
+# of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
@@ -121,12 +122,6 @@ if test -z "$no_pipe" && test -n "$GCC"; then
fi
#------------------------------------------------------------------------
-# Threads support
-#------------------------------------------------------------------------
-
-SC_ENABLE_THREADS
-
-#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
@@ -173,6 +168,30 @@ AS_IF([test $zlib_ok = no], [
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
+#------------------------------------------------------------------------
+# Add stuff for libtommath
+
+libtommath_ok=yes
+AC_ARG_WITH(system-libtommath,
+AS_HELP_STRING([--with-system-libtommath],
+ [use external libtommath (default: true if available, false otherwise)]),
+ [libtommath_ok=${withval}])
+if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
+ AC_CHECK_HEADER([tommath.h],[
+ AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include <tommath.h>])],[
+ libtommath_ok=no])
+ AS_IF([test $libtommath_ok = yes], [
+ AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[
+ libtommath_ok=no])])
+fi
+AS_IF([test $libtommath_ok = yes], [
+ AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
+], [
+ AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
+ AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}])
+ AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}])
+])
+
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
@@ -183,7 +202,6 @@ SC_CONFIG_CFLAGS
SC_ENABLE_SYMBOLS(bccdebug)
-AC_DEFINE(TCL_TOMMATH, 1, [Build libtommath?])
AC_DEFINE(MP_PREC, 4, [Default libtommath precision.])
#--------------------------------------------------------------------
@@ -209,7 +227,7 @@ AC_C_BIGENDIAN
# Check if Posix compliant getcwd exists, if not we'll use getwd.
AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD, 1, [Is getcwd Posix-compliant?])])
# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
-# define USEGETWD even if the Posix getcwd exists. Add a test ?
+# define USEGETWD even if the posix getcwd exists. Add a test ?
AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid)
AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])])
@@ -220,7 +238,7 @@ AC_CHECK_FUNC(mknod, , [AC_DEFINE(NO_MKNOD, 1, [Do we have mknod()])])
AC_CHECK_FUNC(tcdrain, , [AC_DEFINE(NO_TCDRAIN, 1, [Do we have tcdrain()])])
AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME, 1, [Do we have uname()])])
-if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \
+if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print [$]1}'`" -lt 7; then
# prior to Darwin 7, realpath is not threadsafe, so don't
# use it when threads are enabled, c.f. bug # 711232
@@ -234,35 +252,33 @@ SC_TCL_IPV6
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
-if test "${TCL_THREADS}" = 1; then
- SC_TCL_GETPWUID_R
- SC_TCL_GETPWNAM_R
- SC_TCL_GETGRGID_R
- SC_TCL_GETGRNAM_R
- if test "`uname -s`" = "Darwin" && \
- test "`uname -r | awk -F. '{print [$]1}'`" -gt 5; then
- # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
- # are actually MT-safe as they always return pointers
- # from TSD instead of static storage.
- AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1,
- [Do we have MT-safe gethostbyname() ?])
- AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1,
- [Do we have MT-safe gethostbyaddr() ?])
-
- elif test "`uname -s`" = "HP-UX" && \
- test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
- # Starting with HPUX 11.00 (we believe), gethostbyX
- # are actually MT-safe as they always return pointers
- # from TSD instead of static storage.
- AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1,
- [Do we have MT-safe gethostbyname() ?])
- AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1,
- [Do we have MT-safe gethostbyaddr() ?])
+SC_TCL_GETPWUID_R
+SC_TCL_GETPWNAM_R
+SC_TCL_GETGRGID_R
+SC_TCL_GETGRNAM_R
+if test "`uname -s`" = "Darwin" && \
+ test "`uname -r | awk -F. '{print [$]1}'`" -gt 5; then
+ # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
+ # are actually MT-safe as they always return pointers
+ # from TSD instead of static storage.
+ AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1,
+ [Do we have MT-safe gethostbyname() ?])
+ AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1,
+ [Do we have MT-safe gethostbyaddr() ?])
+
+elif test "`uname -s`" = "HP-UX" && \
+ test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
+ # Starting with HPUX 11.00 (we believe), gethostbyX
+ # are actually MT-safe as they always return pointers
+ # from TSD instead of static storage.
+ AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME, 1,
+ [Do we have MT-safe gethostbyname() ?])
+ AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR, 1,
+ [Do we have MT-safe gethostbyaddr() ?])
- else
- SC_TCL_GETHOSTBYNAME_R
- SC_TCL_GETHOSTBYADDR_R
- fi
+else
+ SC_TCL_GETHOSTBYNAME_R
+ SC_TCL_GETHOSTBYADDR_R
fi
#---------------------------------------------------------------------------
@@ -305,6 +321,43 @@ if test $tcl_ok = no; then
AC_DEFINE(NO_FD_SET, 1, [Do we have fd_set?])
fi
+AC_CACHE_CHECK([for pselect], tcl_cv_func_pselect, [
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>]], [[void *func = pselect;]])],[tcl_cv_func_pselect=yes],[tcl_cv_func_pselect=no])])
+tcl_ok=$tcl_cv_func_pselect
+if test $tcl_ok = yes; then
+ AC_DEFINE(HAVE_PSELECT, 1, [Should we use pselect()?])
+fi
+
+#------------------------------------------------------------------------
+# Options for the notifier. Checks for epoll(7) on Linux, and
+# kqueue(2) on {DragonFly,Free,Net,Open}BSD
+#------------------------------------------------------------------------
+
+AC_MSG_CHECKING([for advanced notifier support])
+case x`uname -s` in
+ xLinux)
+ AC_MSG_RESULT([epoll(7)])
+ AC_CHECK_HEADERS([sys/epoll.h],
+ [AC_DEFINE(NOTIFIER_EPOLL, [1], [Is epoll(7) supported?])])
+ AC_CHECK_HEADERS([sys/eventfd.h],
+ [AC_DEFINE(HAVE_EVENTFD, [1], [Is eventfd(2) supported?])]);;
+ xDragonFlyBSD|xFreeBSD|xNetBSD|xOpenBSD)
+ AC_MSG_RESULT([kqueue(2)])
+ # Messy because we want to check if *all* the headers are present, and not
+ # just *any*
+ tcl_kqueue_headers=x
+ AC_CHECK_HEADERS([sys/types.h sys/event.h sys/time.h],
+ [tcl_kqueue_headers=${tcl_kqueue_headers}y])
+ AS_IF([test $tcl_kqueue_headers = xyyy], [
+ AC_DEFINE(NOTIFIER_KQUEUE, [1], [Is kqueue(2) supported?])]);;
+ xDarwin)
+ # Assume that we've got CoreFoundation present (checked elsewhere because
+ # of wider impact).
+ AC_MSG_RESULT([OSX]);;
+ *)
+ AC_MSG_RESULT([none]);;
+esac
+
#------------------------------------------------------------------------------
# Find out all about time handling differences.
#------------------------------------------------------------------------------
@@ -381,37 +434,9 @@ if test $tcl_cv_type_socklen_t = no; then
AC_DEFINE(socklen_t, int, [Define as int if socklen_t is not available])
fi
-AC_CHECK_TYPE([intptr_t], [
- AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
- AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
- for tcl_cv_intptr_t in "int" "long" "long long" none; do
- if test "$tcl_cv_intptr_t" != none; then
- AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
- [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])],
- [tcl_ok=yes], [tcl_ok=no])
- test "$tcl_ok" = yes && break; fi
- done])
- if test "$tcl_cv_intptr_t" != none; then
- AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer
- type wide enough to hold a pointer.])
- fi
-])
-AC_CHECK_TYPE([uintptr_t], [
- AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [
- AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [
- for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \
- none; do
- if test "$tcl_cv_uintptr_t" != none; then
- AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
- [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])],
- [tcl_ok=yes], [tcl_ok=no])
- test "$tcl_ok" = yes && break; fi
- done])
- if test "$tcl_cv_uintptr_t" != none; then
- AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer
- type wide enough to hold a pointer.])
- fi
-])
+AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
+#include <stdint.h>
+]])
#--------------------------------------------------------------------
# If a system doesn't have an opendir function (man, that's old!)
@@ -534,22 +559,10 @@ fi
SC_ENABLE_LANGINFO
#--------------------------------------------------------------------
-# Check for support of chflags and mkstemps functions
-#--------------------------------------------------------------------
-
-AC_CHECK_FUNCS(chflags mkstemps)
-
-#--------------------------------------------------------------------
-# Check for support of isnan() function or macro
+# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
-AC_CACHE_CHECK([isnan], tcl_cv_isnan, [
- AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <math.h>]], [[
-isnan(0.0); /* Generates an error if isnan is missing */
-]])],[tcl_cv_isnan=yes],[tcl_cv_isnan=no])])
-if test $tcl_cv_isnan = no; then
- AC_DEFINE(NO_ISNAN, 1, [Do we have a usable 'isnan'?])
-fi
+AC_CHECK_FUNCS(cfmakeraw chflags mkstemps)
#--------------------------------------------------------------------
# Darwin specific API checks and defines
@@ -792,7 +805,6 @@ if test "`uname -s`" = "Darwin" ; then
echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
- EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic'
AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in])
TCL_YEAR="`date +%Y`"
fi
@@ -857,6 +869,49 @@ eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
VERSION=${TCL_VERSION}
#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+AC_ARG_ENABLE(zipfs,
+ AS_HELP_STRING([--enable-zipfs],
+ [build with Zipfs support (default: on)]),
+ [tcl_ok=$enableval], [tcl_ok=yes])
+if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then
+ #
+ # Find a native compiler
+ #
+ AX_CC_FOR_BUILD
+ #
+ # Find a native zip implementation
+ #
+ SC_ZIPFS_SUPPORT
+ ZIPFS_BUILD=1
+ TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip
+else
+ ZIPFS_BUILD=0
+ TCL_ZIP_FILE=
+fi
+# Do checking message here to not mess up interleaved configure output
+AC_MSG_CHECKING([for building with zipfs])
+if test "${ZIPFS_BUILD}" = 1; then
+ if test "${SHARED_BUILD}" = 0; then
+ ZIPFS_BUILD=2;
+ AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?])
+ else
+ AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\
+ fi
+ AC_MSG_RESULT([yes])
+else
+AC_MSG_RESULT([no])
+INSTALL_LIBRARIES=install-libraries
+INSTALL_MSGS=install-msgs
+fi
+AC_SUBST(ZIPFS_BUILD)
+AC_SUBST(TCL_ZIP_FILE)
+AC_SUBST(INSTALL_LIBRARIES)
+AC_SUBST(INSTALL_MSGS)
+
+
+#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
@@ -913,6 +968,7 @@ AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_YEAR)
AC_SUBST(PKG_CFG_ARGS)
+AC_SUBST(TCL_ZIP_FILE)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in
index 25b9376..b1b483b 100644
--- a/unix/dltest/Makefile.in
+++ b/unix/dltest/Makefile.in
@@ -17,7 +17,7 @@ TCL_VERSION= @TCL_VERSION@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
-CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@
+CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1 -Wall -Wextra -Wc++-compat -Wconversion -Werror
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
@@ -25,11 +25,11 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
-all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX}
+all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgt${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX}
@if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi
@touch ../dltest.marker
-dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} pkgooa${DLTEST_SUFFIX}
+dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgt${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} pkgooa${DLTEST_SUFFIX}
@touch ../dltest.marker
pkga.o: $(SRC_DIR)/pkga.c
@@ -47,6 +47,9 @@ pkgd.o: $(SRC_DIR)/pkgd.c
pkge.o: $(SRC_DIR)/pkge.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
+pkgt.o: $(SRC_DIR)/pkgt.c
+ $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgt.c
+
pkgua.o: $(SRC_DIR)/pkgua.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c
@@ -68,6 +71,9 @@ pkgd${SHLIB_SUFFIX}: pkgd.o
pkge${SHLIB_SUFFIX}: pkge.o
${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
+pkgt${SHLIB_SUFFIX}: pkgt.o
+ ${SHLIB_LD} -o pkgt${SHLIB_SUFFIX} pkgt.o ${SHLIB_LD_LIBS}
+
pkgua${SHLIB_SUFFIX}: pkgua.o
${SHLIB_LD} -o pkgua${SHLIB_SUFFIX} pkgua.o ${SHLIB_LD_LIBS}
@@ -89,6 +95,9 @@ pkgd${DLTEST_SUFFIX}: pkgd.o
pkge${DLTEST_SUFFIX}: pkge.o
${DLTEST_LD} -o pkge${DLTEST_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
+pkgt${DLTEST_SUFFIX}: pkgt.o
+ ${DLTEST_LD} -o pkgt${DLTEST_SUFFIX} pkgt.o ${SHLIB_LD_LIBS}
+
pkgua${DLTEST_SUFFIX}: pkgua.o
${DLTEST_LD} -o pkgua${DLTEST_SUFFIX} pkgua.o ${SHLIB_LD_LIBS}
diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c
index c2d814f..d24a23e 100644
--- a/unix/dltest/pkga.c
+++ b/unix/dltest/pkga.c
@@ -4,7 +4,7 @@
* This file contains a simple Tcl package "pkga" that is intended for
* testing the Tcl dynamic loading facilities.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -14,15 +14,6 @@
#include "tcl.h"
/*
- * Prototypes for procedures defined later in this file:
- */
-
-static int Pkga_EqObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int Pkga_QuoteObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-
-/*
*----------------------------------------------------------------------
*
* Pkga_EqObjCmd --
@@ -42,7 +33,7 @@ static int Pkga_QuoteObjCmd(ClientData clientData,
static int
Pkga_EqObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -60,7 +51,7 @@ Pkga_EqObjCmd(
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
- result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
+ result = (Tcl_UtfNcmp(str1, str2, (size_t)len1) == 0);
} else {
result = 0;
}
@@ -87,7 +78,7 @@ Pkga_EqObjCmd(
static int
Pkga_QuoteObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c
index e66c9ec..c16a362 100644
--- a/unix/dltest/pkgb.c
+++ b/unix/dltest/pkgb.c
@@ -1,11 +1,11 @@
/*
* pkgb.c --
*
- * This file contains a simple Tcl package "pkgb" that is intended for
+ * This file contains a simple Tcl package "Pkgb" that is intended for
* testing the Tcl dynamic loading facilities. It can be used in both
* safe and unsafe interpreters.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,17 +18,6 @@
#endif
/*
- * Prototypes for procedures defined later in this file:
- */
-
-static int Pkgb_SubObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int Pkgb_UnsafeObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int Pkgb_DemoObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-
-/*
*----------------------------------------------------------------------
*
* Pkgb_SubObjCmd --
@@ -51,7 +40,7 @@ static int Pkgb_DemoObjCmd(ClientData clientData,
static int
Pkgb_SubObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -93,7 +82,7 @@ Pkgb_SubObjCmd(
static int
Pkgb_UnsafeObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -107,24 +96,24 @@ Pkgb_UnsafeObjCmd(
static int
Pkgb_DemoObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
-#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4)
- Tcl_Obj *first;
+ Tcl_WideInt numChars;
+ int result;
(void)dummy;
- (void)objc;
- (void)objv;
- if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first)
- == TCL_OK) {
- Tcl_SetObjResult(interp, first);
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg1 arg2 num");
+ return TCL_ERROR;
}
-#else
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1));
-#endif
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &numChars) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = Tcl_UtfNcmp(Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), (size_t)numChars);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c
index 46f6e86..8e9c829 100644
--- a/unix/dltest/pkgc.c
+++ b/unix/dltest/pkgc.c
@@ -5,7 +5,7 @@
* testing the Tcl dynamic loading facilities. It can be used in both
* safe and unsafe interpreters.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 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,15 +15,6 @@
#include "tcl.h"
/*
- * Prototypes for procedures defined later in this file:
- */
-
-static int Pkgc_SubObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int Pkgc_UnsafeObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-
-/*
*----------------------------------------------------------------------
*
* Pkgc_SubObjCmd --
@@ -42,7 +33,7 @@ static int Pkgc_UnsafeObjCmd(ClientData clientData,
static int
Pkgc_SubObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -81,7 +72,7 @@ Pkgc_SubObjCmd(
static int
Pkgc_UnsafeObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c
index d64c807..1b97d4c 100644
--- a/unix/dltest/pkgd.c
+++ b/unix/dltest/pkgd.c
@@ -1,11 +1,11 @@
/*
* pkgd.c --
*
- * This file contains a simple Tcl package "pkgd" that is intended for
+ * This file contains a simple Tcl package "PKGD" that is intended for
* testing the Tcl dynamic loading facilities. It can be used in both
* safe and unsafe interpreters.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 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,15 +15,6 @@
#include "tcl.h"
/*
- * Prototypes for procedures defined later in this file:
- */
-
-static int Pkgd_SubObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int Pkgd_UnsafeObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-
-/*
*----------------------------------------------------------------------
*
* Pkgd_SubObjCmd --
@@ -42,7 +33,7 @@ static int Pkgd_UnsafeObjCmd(ClientData clientData,
static int
Pkgd_SubObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -81,7 +72,7 @@ Pkgd_SubObjCmd(
static int
Pkgd_UnsafeObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c
index f46ca74..26a4b79 100644
--- a/unix/dltest/pkge.c
+++ b/unix/dltest/pkge.c
@@ -5,7 +5,7 @@
* testing the Tcl dynamic loading facilities. Its Init procedure returns
* an error in order to test how this is handled.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 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/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c
index 06ff3ac..444bb81 100644
--- a/unix/dltest/pkgooa.c
+++ b/unix/dltest/pkgooa.c
@@ -4,7 +4,7 @@
* This file contains a simple Tcl package "pkgooa" that is intended for
* testing the Tcl dynamic loading facilities.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -33,7 +33,7 @@
static int
Pkgooa_StubsOKObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -88,6 +88,21 @@ static TclOOStubs stubsCopy = {
#ifdef Tcl_MethodIsPrivate
,NULL
#endif
+#ifdef Tcl_GetClassOfObject
+ ,NULL
+#endif
+#ifdef Tcl_GetObjectClassName
+ ,NULL
+#endif
+#ifdef Tcl_MethodIsType2
+ ,NULL
+#endif
+#ifdef Tcl_NewInstanceMethod2
+ ,NULL
+#endif
+#ifdef Tcl_NewMethod2
+ ,NULL
+#endif
};
DLLEXPORT int
diff --git a/unix/dltest/pkgt.c b/unix/dltest/pkgt.c
new file mode 100644
index 0000000..0c4b3d7
--- /dev/null
+++ b/unix/dltest/pkgt.c
@@ -0,0 +1,116 @@
+/*
+ * pkgt.c --
+ *
+ * This file contains a simple Tcl package "pkgt" that is intended for
+ * testing the Tcl dynamic loading facilities.
+ *
+ * Copyright © 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#undef STATIC_BUILD
+#include "tcl.h"
+
+static int TraceProc2 (
+ void *clientData,
+ Tcl_Interp *interp,
+ ptrdiff_t level,
+ const char *command,
+ Tcl_Command commandInfo,
+ ptrdiff_t objc,
+ struct Tcl_Obj *const *objv)
+{
+ (void)clientData;
+ (void)interp;
+ (void)level;
+ (void)command;
+ (void)commandInfo;
+ (void)objc;
+ (void)objv;
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Pkgt_EqObjCmd2 --
+ *
+ * This procedure is invoked to process the "pkgt_eq" Tcl command. It
+ * expects two arguments and returns 1 if they are the same, 0 if they
+ * are different.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+Pkgt_EqObjCmd2(
+ void *dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ ptrdiff_t objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_WideInt result;
+ const char *str1, *str2;
+ ptrdiff_t len1, len2;
+ (void)dummy;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
+ return TCL_ERROR;
+ }
+
+ str1 = Tcl_GetStringFromObj(objv[1], &len1);
+ str2 = Tcl_GetStringFromObj(objv[2], &len2);
+ if (len1 == len2) {
+ result = (Tcl_UtfNcmp(str1, str2, (size_t)len1) == 0);
+ } else {
+ result = 0;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Pkgt_Init --
+ *
+ * This is a package initialization procedure, which is called by Tcl
+ * when this package is to be added to an interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+DLLEXPORT int
+Pkgt_Init(
+ Tcl_Interp *interp) /* Interpreter in which the package is to be
+ * made available. */
+{
+ int code;
+
+ if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
+ return TCL_ERROR;
+ }
+ code = Tcl_PkgProvide(interp, "pkgt", "1.0");
+ if (code != TCL_OK) {
+ return code;
+ }
+ Tcl_CreateObjCommand2(interp, "pkgt_eq", Pkgt_EqObjCmd2, NULL, NULL);
+ Tcl_CreateObjTrace2(interp, 0, 0, TraceProc2, NULL, NULL);
+ return TCL_OK;
+}
diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c
index e6a4fbb..409d7c1 100644
--- a/unix/dltest/pkgua.c
+++ b/unix/dltest/pkgua.c
@@ -4,27 +4,16 @@
* This file contains a simple Tcl package "pkgua" that is intended for
* testing the Tcl dynamic unloading facilities.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
- * Copyright (c) 2004 Georgios Petasis
+ * Copyright © 1995 Sun Microsystems, Inc.
+ * Copyright © 2004 Georgios Petasis
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#undef STATIC_BUILD
#include "tcl.h"
/*
- * Prototypes for procedures defined later in this file:
- */
-
-static int PkguaEqObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int PkguaQuoteObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static void CommandDeleted(ClientData clientData);
-
-/*
* In the following hash table we are going to store a struct that holds all
* the command tokens created by Tcl_CreateObjCommand in an interpreter,
* indexed by the interpreter. In this way, we can find which command tokens
@@ -42,7 +31,7 @@ static Tcl_ThreadDataKey dataKey;
#define MAX_REGISTERED_COMMANDS 2
static void
-CommandDeleted(ClientData clientData)
+CommandDeleted(void *clientData)
{
Tcl_Command *cmdToken = (Tcl_Command *)clientData;
*cmdToken = NULL;
@@ -131,7 +120,7 @@ PkguaDeleteTokens(
static int
PkguaEqObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -149,7 +138,7 @@ PkguaEqObjCmd(
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
- result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
+ result = (Tcl_UtfNcmp(str1, str2, (size_t)len1) == 0);
} else {
result = 0;
}
@@ -176,7 +165,7 @@ PkguaEqObjCmd(
static int
PkguaQuoteObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
diff --git a/unix/installManPage b/unix/installManPage
index a442892..86f9860 100755
--- a/unix/installManPage
+++ b/unix/installManPage
@@ -60,20 +60,35 @@ test -z "$SymOrLoc" && SymOrLoc="$Dir/"
#
Names=`sed -n '
# Look for a line that starts with .SH NAME
- /^\.SH NAME/{
-# Read next line
- n
-# Remove all commas ...
- s/,//g
-# ... and backslash-escaped spaces.
- s/\\\ //g
-# Delete from \- to the end of line
- s/ \\\-.*//
-# Convert all non-space non-alphanum sequences
-# to single underscores.
- s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g
-# print the result and exit
- p;q
+ /^\.SH NAME/,/^\./{
+
+
+ /^\./!{
+
+ # Remove all commas...
+ s/,//g
+
+ # ... and backslash-escaped spaces.
+ s/\\\ //g
+
+ /\\\-.*/{
+ # Delete from \- to the end of line
+ s/ \\\-.*//
+ h
+ s/.*/./
+ x
+ }
+
+ # Convert all non-space non-alphanum sequences
+ # to single underscores.
+ s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g
+ p
+ g
+ /^\./{
+ q
+ }
+ }
+
}' $ManPage`
if test -z "$Names" ; then
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 0ef9f3d..3717893 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -93,11 +93,11 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/pkg/lib 2>/dev/null` \
- `ls -d /usr/lib/tcl8.6 2>/dev/null` \
+ `ls -d /usr/lib/tcl8.7 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
- `ls -d /usr/local/lib/tcl8.6 2>/dev/null` \
- `ls -d /usr/local/lib/tcl/tcl8.6 2>/dev/null` \
+ `ls -d /usr/local/lib/tcl8.7 2>/dev/null` \
+ `ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \
; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i; pwd)`"
@@ -226,11 +226,11 @@ AC_DEFUN([SC_PATH_TKCONFIG], [
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/pkg/lib 2>/dev/null` \
- `ls -d /usr/lib/tk8.6 2>/dev/null` \
+ `ls -d /usr/lib/tk8.7 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
- `ls -d /usr/local/lib/tk8.6 2>/dev/null` \
- `ls -d /usr/local/lib/tcl/tk8.6 2>/dev/null` \
+ `ls -d /usr/local/lib/tk8.7 2>/dev/null` \
+ `ls -d /usr/local/lib/tcl/tk8.7 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i; pwd)`"
@@ -571,114 +571,6 @@ AC_DEFUN([SC_ENABLE_FRAMEWORK], [
])
#------------------------------------------------------------------------
-# SC_ENABLE_THREADS --
-#
-# Specify if thread support should be enabled
-#
-# Arguments:
-# none
-#
-# Results:
-#
-# Adds the following arguments to configure:
-# --enable-threads
-#
-# Sets the following vars:
-# THREADS_LIBS Thread library(s)
-#
-# Defines the following vars:
-# TCL_THREADS
-# _REENTRANT
-# _THREAD_SAFE
-#
-#------------------------------------------------------------------------
-
-AC_DEFUN([SC_ENABLE_THREADS], [
- AC_ARG_ENABLE(threads,
- AS_HELP_STRING([--enable-threads],
- [build with threads (default: on)]),
- [tcl_ok=$enableval], [tcl_ok=yes])
-
- if test "${TCL_THREADS}" = 1; then
- tcl_threaded_core=1;
- fi
-
- if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then
- TCL_THREADS=1
- # USE_THREAD_ALLOC tells us to try the special thread-based
- # allocator that significantly reduces lock contention
- AC_DEFINE(USE_THREAD_ALLOC, 1,
- [Do we want to use the threaded memory allocator?])
- AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
- if test "`uname -s`" = "SunOS" ; then
- AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1,
- [Do we really want to follow the standard? Yes we do!])
- fi
- AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?])
- AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
- if test "$tcl_ok" = "no"; then
- # Check a little harder for __pthread_mutex_init in the same
- # library, as some systems hide it there until pthread.h is
- # defined. We could alternatively do an AC_TRY_COMPILE with
- # pthread.h, but that will work with libpthread really doesn't
- # exist, like AIX 4.2. [Bug: 4359]
- AC_CHECK_LIB(pthread, __pthread_mutex_init,
- tcl_ok=yes, tcl_ok=no)
- fi
-
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -lpthread"
- else
- AC_CHECK_LIB(pthreads, pthread_mutex_init,
- tcl_ok=yes, tcl_ok=no)
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -lpthreads"
- else
- AC_CHECK_LIB(c, pthread_mutex_init,
- tcl_ok=yes, tcl_ok=no)
- if test "$tcl_ok" = "no"; then
- AC_CHECK_LIB(c_r, pthread_mutex_init,
- tcl_ok=yes, tcl_ok=no)
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -pthread"
- else
- TCL_THREADS=0
- AC_MSG_WARN([Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...])
- fi
- fi
- fi
- fi
-
- # Does the pthread-implementation provide
- # 'pthread_attr_setstacksize' ?
-
- ac_saved_libs=$LIBS
- LIBS="$LIBS $THREADS_LIBS"
- AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork)
- LIBS=$ac_saved_libs
- else
- TCL_THREADS=0
- fi
- # Do checking message here to not mess up interleaved configure output
- AC_MSG_CHECKING([for building with threads])
- if test "${TCL_THREADS}" = 1; then
- AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?])
- if test "${tcl_threaded_core}" = 1; then
- AC_MSG_RESULT([yes (threaded core)])
- else
- AC_MSG_RESULT([yes])
- fi
- else
- AC_MSG_RESULT([no])
- fi
-
- AC_SUBST(TCL_THREADS)
-])
-
-#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
# Specify if debugging symbols should be used.
@@ -867,8 +759,7 @@ AC_DEFUN([SC_CONFIG_MANPAGES], [
#
# Determine what the system is (some things cannot be easily checked
# on a feature-driven basis, alas). This can usually be done via the
-# "uname" command, but there are a few systems, like Next, where
-# this doesn't work.
+# "uname" command.
#
# Arguments:
# none
@@ -882,20 +773,14 @@ AC_DEFUN([SC_CONFIG_MANPAGES], [
AC_DEFUN([SC_CONFIG_SYSTEM], [
AC_CACHE_CHECK([system version], tcl_cv_sys_version, [
- if test -f /usr/lib/NextStep/software_version; then
- tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
+ if test "${TEA_PLATFORM}" = "windows" ; then
+ tcl_cv_sys_version=windows
else
tcl_cv_sys_version=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
AC_MSG_WARN([can't find uname command])
tcl_cv_sys_version=unknown
else
- # Special check for weird MP-RAS system (uname returns weird
- # results, and the version is kept in special file).
-
- if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
- tcl_cv_sys_version=MP-RAS-`awk '{print $[3]}' /etc/.relid`
- fi
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
@@ -958,8 +843,8 @@ AC_DEFUN([SC_CONFIG_SYSTEM], [
# shared libraries. The value of the symbol defaults to
# "${LIBS}" if all of the dependent libraries should
# be specified when creating a shared library. If
-# dependent libraries should not be specified (as on
-# SunOS 4.x, where they cause the link to fail, or in
+# dependent libraries should not be specified (as on some
+# SunOS systems, where they cause the link to fail, or in
# general if Tcl and Tk aren't themselves shared
# libraries), then this symbol has an empty string
# as its value.
@@ -1075,7 +960,15 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
- CFLAGS_WARNING="-Wall -Wpointer-arith"
+ CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith"
+ case "${CC}" in
+ *++|*++-*)
+ ;;
+ *)
+ CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers"
+ ;;
+ esac
+
], [
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
@@ -1086,10 +979,10 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
PLAT_OBJS=""
PLAT_SRCS=""
LDAIX_SRC=""
- AS_IF([test "x${SHLIB_VERSION}" = x],[SHLIB_VERSION=".1.0"],[SHLIB_VERSION=".${SHLIB_VERSION}"])
+ AS_IF([test "x${SHLIB_VERSION}" = x], [SHLIB_VERSION="1.0"])
case $system in
AIX-*)
- AS_IF([test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"], [
+ AS_IF([test "$GCC" != "yes"], [
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r|*_r\ *)
@@ -1210,9 +1103,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
if test "$ac_cv_cygwin" = "no"; then
AC_MSG_ERROR([${CC} is not a cygwin compiler.])
fi
- if test "x${TCL_THREADS}" = "x0"; then
- AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads])
- fi
do64bit_ok=yes
if test "x${SHARED_BUILD}" = "x1"; then
echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32"
@@ -1415,7 +1305,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
])
# The combo of gcc + glibc has a bug related to inlining of
- # functions like strtod(). The -fno-builtin flag should address
+ # functions like strtol()/strtoul(). The -fno-builtin flag should address
# this problem but it does not work. The -fno-inline flag is kind
# of overkill but it works. Disable inlining only when one of the
# files in compat/*.c is being linked in.
@@ -1434,27 +1324,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
;;
- MP-RAS-02*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- MP-RAS-*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- LDFLAGS="$LDFLAGS -Wl,-Bexport"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
@@ -1472,15 +1341,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}'
+ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
- AS_IF([test "${TCL_THREADS}" = "1"], [
- # On OpenBSD: Compile with -pthread
- # Don't link with -lpthread
- LIBS=`echo $LIBS | sed s/-lpthread//`
- CFLAGS="$CFLAGS -pthread"
- ])
+ # On OpenBSD: Compile with -pthread
+ # Don't link with -lpthread
+ LIBS=`echo $LIBS | sed s/-lpthread//`
+ CFLAGS="$CFLAGS -pthread"
# OpenBSD doesn't do version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
TCL_LIB_VERSIONS_OK=nodots
@@ -1496,12 +1363,10 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- AS_IF([test "${TCL_THREADS}" = "1"], [
- # The -pthread needs to go in the CFLAGS, not LIBS
- LIBS=`echo $LIBS | sed s/-pthread//`
- CFLAGS="$CFLAGS -pthread"
- LDFLAGS="$LDFLAGS -pthread"
- ])
+ # The -pthread needs to go in the CFLAGS, not LIBS
+ LIBS=`echo $LIBS | sed s/-pthread//`
+ CFLAGS="$CFLAGS -pthread"
+ LDFLAGS="$LDFLAGS -pthread"
;;
Darwin-*)
CFLAGS_OPTIMIZE="-O2"
@@ -1652,47 +1517,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
])
])
;;
- NEXTSTEP-*)
- SHLIB_CFLAGS=""
- SHLIB_LD='${CC} -nostdlib -r'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadNext.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
OS/390-*)
SHLIB_LD_LIBS=""
CFLAGS_OPTIMIZE="" # Optimizer is buggy
AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h
[Should OS/390 do the right thing with sockets?])
;;
- OSF1-1.0|OSF1-1.1|OSF1-1.2)
- # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
- SHLIB_CFLAGS=""
- # Hack: make package name same as library name
- SHLIB_LD='ld -R -export $@:'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadOSF.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- OSF1-1.*)
- # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
- SHLIB_CFLAGS="-fPIC"
- AS_IF([test "$SHARED_BUILD" = 1], [SHLIB_LD="ld -shared"], [
- SHLIB_LD="ld -non_shared"
- ])
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
@@ -1710,22 +1540,19 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"])
# see pthread_intro(3) for pthread support on osf1, k.furukawa
- AS_IF([test "${TCL_THREADS}" = 1], [
- CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
- CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
- LIBS=`echo $LIBS | sed s/-lpthreads//`
- AS_IF([test "$GCC" = yes], [
- LIBS="$LIBS -lpthread -lmach -lexc"
- ], [
- CFLAGS="$CFLAGS -pthread"
- LDFLAGS="$LDFLAGS -pthread"
- ])
+ CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
+ CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
+ LIBS=`echo $LIBS | sed s/-lpthreads//`
+ AS_IF([test "$GCC" = yes], [
+ LIBS="$LIBS -lpthread -lmach -lexc"
+ ], [
+ CFLAGS="$CFLAGS -pthread"
+ LDFLAGS="$LDFLAGS -pthread"
])
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
- SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
@@ -1754,35 +1581,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
- SINIX*5.4*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- SunOS-4*)
- SHLIB_CFLAGS="-PIC"
- SHLIB_LD="ld"
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
-
- # SunOS can't handle version numbers with dots in them in library
- # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it
- # requires an extra version number at the end of .so file names.
- # So, the library has to have a name like libtcl75.so.1.0
-
- SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}'
- UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
- TCL_LIB_VERSIONS_OK=nodots
- ;;
SunOS-5.[[0-6]])
# Careful to not let 5.10+ fall into this case
@@ -1985,6 +1783,7 @@ dnl # preprocessing tests use only CPPFLAGS.
HP-UX*) ;;
Darwin-*) ;;
IRIX*) ;;
+ Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-*) ;;
SCO_SV-3.2*) ;;
@@ -2067,6 +1866,16 @@ dnl # preprocessing tests use only CPPFLAGS.
else
CFLAGS_NOLTO=""
fi
+ AC_CACHE_CHECK([if the compiler understands -finput-charset],
+ tcl_cv_cc_input_charset, [
+ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8"
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_input_charset=yes],[tcl_cv_cc_input_charset=no])
+ CFLAGS=$hold_cflags])
+ if test $tcl_cv_cc_input_charset = yes; then
+ CFLAGS="$CFLAGS -finput-charset=UTF-8"
+ fi
+
+ AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],)
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
@@ -2112,8 +1921,8 @@ dnl # preprocessing tests use only CPPFLAGS.
#
# Supply substitutes for missing POSIX header files. Special
# notes:
-# - stdlib.h doesn't define strtol, strtoul, or
-# strtod insome versions of SunOS
+# - stdlib.h doesn't define strtol or strtoul in some
+# versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
#
@@ -2124,8 +1933,6 @@ dnl # preprocessing tests use only CPPFLAGS.
#
# Defines some of the following vars:
# NO_DIRENT_H
-# NO_FLOAT_H
-# NO_VALUES_H
# NO_STDLIB_H
# NO_STRING_H
# NO_SYS_WAIT_H
@@ -2162,12 +1969,9 @@ closedir(d);
AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
fi
- AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have <float.h>?])])
- AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have <values.h>?])])
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
- AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0)
if test $tcl_ok = 0; then
AC_DEFINE(NO_STDLIB_H, 1, [Do we have <stdlib.h>?])
fi
@@ -2306,10 +2110,6 @@ AC_DEFUN([SC_BLOCKING_STYLE], [
AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?])
AC_MSG_RESULT([FIONBIO])
;;
- SunOS-4*)
- AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?])
- AC_MSG_RESULT([FIONBIO])
- ;;
*)
AC_MSG_RESULT([O_NONBLOCK])
;;
@@ -2337,7 +2137,7 @@ AC_DEFUN([SC_BLOCKING_STYLE], [
AC_DEFUN([SC_TIME_HANDLER], [
AC_CHECK_HEADERS(sys/time.h)
- AC_HEADER_TIME
+ AC_CHECK_HEADERS_ONCE([sys/time.h])
AC_CHECK_FUNCS(gmtime_r localtime_r mktime)
@@ -2392,13 +2192,21 @@ AC_DEFUN([SC_TIME_HANDLER], [
#
# Search for the libraries needed to link the Tcl shell.
# Things like the math library (-lm), socket stuff (-lsocket vs.
-# -lnsl), zlib (-lz) and libtommath (-ltommath) are dealt with here.
+# -lnsl), zlib (-lz) and libtommath (-ltommath) or thread library
+# (-lpthread) are dealt with here.
#
# Arguments:
# None.
#
# Results:
#
+# Sets the following vars:
+# THREADS_LIBS Thread library(s)
+#
+# Defines the following vars:
+# _REENTRANT
+# _THREAD_SAFE
+#
# Might append to the following vars:
# LIBS
# MATH_LIBS
@@ -2456,6 +2264,55 @@ AC_DEFUN([SC_TCL_LINK_LIBS], [
fi
AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname,
[LIBS="$LIBS -lnsl"])])
+
+ AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?])
+ AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?])
+ AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
+ if test "$tcl_ok" = "no"; then
+ # Check a little harder for __pthread_mutex_init in the same
+ # library, as some systems hide it there until pthread.h is
+ # defined. We could alternatively do an AC_TRY_COMPILE with
+ # pthread.h, but that will work with libpthread really doesn't
+ # exist, like AIX 4.2. [Bug: 4359]
+ AC_CHECK_LIB(pthread, __pthread_mutex_init,
+ tcl_ok=yes, tcl_ok=no)
+ fi
+
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -lpthread"
+ else
+ AC_CHECK_LIB(pthreads, pthread_mutex_init,
+ _ok=yes, tcl_ok=no)
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -lpthreads"
+ else
+ AC_CHECK_LIB(c, pthread_mutex_init,
+ tcl_ok=yes, tcl_ok=no)
+ if test "$tcl_ok" = "no"; then
+ AC_CHECK_LIB(c_r, pthread_mutex_init,
+ tcl_ok=yes, tcl_ok=no)
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -pthread"
+ else
+ AC_MSG_WARN([Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile...])
+ fi
+ fi
+ fi
+ fi
+
+ # Does the pthread-implementation provide
+ # 'pthread_attr_setstacksize' ?
+
+ ac_saved_libs=$LIBS
+ LIBS="$LIBS $THREADS_LIBS"
+ AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork)
+ LIBS=$ac_saved_libs
+
+ # TIP #509
+ AC_CHECK_DECLS([PTHREAD_MUTEX_RECURSIVE],tcl_ok=yes,tcl_ok=no, [[#include <pthread.h>]])
])
#--------------------------------------------------------------------
@@ -2514,7 +2371,6 @@ AC_DEFUN([SC_TCL_EARLY_FLAGS],[
#
# Might define the following vars:
# TCL_WIDE_INT_IS_LONG
-# TCL_WIDE_INT_TYPE
# HAVE_STRUCT_DIRENT64, HAVE_DIR64
# HAVE_STRUCT_STAT64
# HAVE_TYPE_OFF64_T
@@ -2522,26 +2378,20 @@ AC_DEFUN([SC_TCL_EARLY_FLAGS],[
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
- AC_MSG_CHECKING([for 64-bit integer type])
+ AC_MSG_CHECKING([if 'long' and 'long long' have the same size (64-bit)?])
AC_CACHE_VAL(tcl_cv_type_64bit,[
tcl_cv_type_64bit=none
- # See if the compiler knows natively about __int64
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[__int64 value = (__int64) 0;]])],
- [tcl_type_64bit=__int64], [tcl_type_64bit="long long"])
- # See if we should use long anyway Note that we substitute in the
+ # See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[switch (0) {
- case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ;
- }]])],[tcl_cv_type_64bit=${tcl_type_64bit}],[])])
+ case 1: case (sizeof(long long)==sizeof(long)): ;
+ }]])],[tcl_cv_type_64bit="long long"],[])])
if test "${tcl_cv_type_64bit}" = none ; then
- AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?])
- AC_MSG_RESULT([using long])
+ AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, ['long' and 'long long' have the same size])
+ AC_MSG_RESULT([yes])
else
- AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit},
- [What type should be used to define wide integers?])
- AC_MSG_RESULT([${tcl_cv_type_64bit}])
-
+ AC_MSG_RESULT([no])
# Now check for auxiliary declarations
AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
@@ -2607,14 +2457,14 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding,
AS_HELP_STRING([--with-encoding],
- [encoding for configuration values (default: iso8859-1)]),
+ [encoding for configuration values (default: utf-8)]),
[with_tcencoding=${withval}])
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}",
[What encoding should be used for embedded configuration info?])
else
- AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1",
+ AC_DEFINE(TCL_CFGVAL_ENCODING,"utf-8",
[What encoding should be used for embedded configuration info?])
fi
])
@@ -3085,6 +2935,152 @@ if test "x$NEED_FAKE_RFC2553" = "x1"; then
AC_CHECK_FUNC(strlcpy)
fi
])
+
+#------------------------------------------------------------------------
+# SC_CC_FOR_BUILD
+# For cross compiles, locate a C compiler that can generate native binaries.
+#
+# Arguments:
+# none
+#
+# Results:
+# Substitutes the following vars:
+# CC_FOR_BUILD
+# EXEEXT_FOR_BUILD
+#------------------------------------------------------------------------
+
+dnl Get a default for CC_FOR_BUILD to put into Makefile.
+AC_DEFUN([AX_CC_FOR_BUILD],[# Put a plausible default for CC_FOR_BUILD in Makefile.
+ if test -z "$CC_FOR_BUILD"; then
+ if test "x$cross_compiling" = "xno"; then
+ CC_FOR_BUILD='$(CC)'
+ else
+ AC_MSG_CHECKING([for gcc])
+ AC_CACHE_VAL(ac_cv_path_cc, [
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/gcc 2> /dev/null` \
+ `ls -r $dir/gcc 2> /dev/null` ; do
+ if test x"$ac_cv_path_cc" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_cc=$j
+ break
+ fi
+ fi
+ done
+ done
+ ])
+ fi
+ fi
+ AC_SUBST(CC_FOR_BUILD)
+ # Also set EXEEXT_FOR_BUILD.
+ if test "x$cross_compiling" = "xno"; then
+ EXEEXT_FOR_BUILD='$(EXEEXT)'
+ OBJEXT_FOR_BUILD='$(OBJEXT)'
+ else
+ OBJEXT_FOR_BUILD='.no'
+ AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext,
+ [rm -f conftest*
+ echo 'int main () { return 0; }' > conftest.c
+ bfd_cv_build_exeext=
+ ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
+ for file in conftest.*; do
+ case $file in
+ *.c | *.o | *.obj | *.ilk | *.pdb) ;;
+ *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
+ esac
+ done
+ rm -f conftest*
+ test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no])
+ EXEEXT_FOR_BUILD=""
+ test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
+ fi
+ AC_SUBST(EXEEXT_FOR_BUILD)])dnl
+ AC_SUBST(OBJEXT_FOR_BUILD)])dnl
+])
+
+
+#------------------------------------------------------------------------
+# SC_ZIPFS_SUPPORT
+# Locate a zip encoder installed on the system path, or none.
+#
+# Arguments:
+# none
+#
+# Results:
+# Substitutes the following vars:
+# MACHER_PROG
+# ZIP_PROG
+# ZIP_PROG_OPTIONS
+# ZIP_PROG_VFSSEARCH
+# ZIP_INSTALL_OBJS
+#------------------------------------------------------------------------
+
+AC_DEFUN([SC_ZIPFS_SUPPORT], [
+ MACHER_PROG=""
+ ZIP_PROG=""
+ ZIP_PROG_OPTIONS=""
+ ZIP_PROG_VFSSEARCH=""
+ ZIP_INSTALL_OBJS=""
+
+ AC_MSG_CHECKING([for macher])
+ AC_CACHE_VAL(ac_cv_path_macher, [
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/macher 2> /dev/null` \
+ `ls -r $dir/macher 2> /dev/null` ; do
+ if test x"$ac_cv_path_macher" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_macher=$j
+ break
+ fi
+ fi
+ done
+ done
+ ])
+ if test -f "$ac_cv_path_macher" ; then
+ MACHER_PROG="$ac_cv_path_macher"
+ AC_MSG_RESULT([$MACHER_PROG])
+ AC_MSG_RESULT([Found macher in environment])
+ fi
+ AC_MSG_CHECKING([for zip])
+ AC_CACHE_VAL(ac_cv_path_zip, [
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/zip 2> /dev/null` \
+ `ls -r $dir/zip 2> /dev/null` ; do
+ if test x"$ac_cv_path_zip" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_zip=$j
+ break
+ fi
+ fi
+ done
+ done
+ ])
+ if test -f "$ac_cv_path_zip" ; then
+ ZIP_PROG="$ac_cv_path_zip"
+ AC_MSG_RESULT([$ZIP_PROG])
+ ZIP_PROG_OPTIONS="-rq"
+ ZIP_PROG_VFSSEARCH="*"
+ AC_MSG_RESULT([Found INFO Zip in environment])
+ # Use standard arguments for zip
+ else
+ # It is not an error if an installed version of Zip can't be located.
+ # We can use the locally distributed minizip instead
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG_OPTIONS="-o -r"
+ ZIP_PROG_VFSSEARCH="*"
+ ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
+ AC_MSG_RESULT([No zip found on PATH. Building minizip])
+ fi
+ AC_SUBST(MACHER_PROG)
+ AC_SUBST(ZIP_PROG)
+ AC_SUBST(ZIP_PROG_OPTIONS)
+ AC_SUBST(ZIP_PROG_VFSSEARCH)
+ AC_SUBST(ZIP_INSTALL_OBJS)
+])
+
# Local Variables:
# mode: autoconf
# End:
diff --git a/unix/tcl.pc.in b/unix/tcl.pc.in
index 93b5e69..5f90c41 100644
--- a/unix/tcl.pc.in
+++ b/unix/tcl.pc.in
@@ -10,7 +10,7 @@ Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: https://www.tcl-lang.org/
Version: @TCL_VERSION@@TCL_PATCH_LEVEL@
-Requires.private: zlib >= 1.2.3
+Requires.private: zlib >= 1.2.3, libtommath >= 1.2.0
Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@
Libs.private: @TCL_LIBS@
Cflags: -I${includedir}
diff --git a/unix/tcl.spec b/unix/tcl.spec
index f4177a4..3956126 100644
--- a/unix/tcl.spec
+++ b/unix/tcl.spec
@@ -4,7 +4,7 @@
Name: tcl
Summary: Tcl scripting language development environment
-Version: 8.6.13
+Version: 8.7a6
Release: 2
License: BSD
Group: Development/Languages
diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c
index 552f9e4..b203487 100644
--- a/unix/tclAppInit.c
+++ b/unix/tclAppInit.c
@@ -12,12 +12,15 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#undef BUILD_tcl
-#undef STATIC_BUILD
#include "tcl.h"
-#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7
+#if TCL_MAJOR_VERSION < 9
+# if defined(USE_TCL_STUBS)
+# error "Don't build with USE_TCL_STUBS!"
+# endif
+# if TCL_MINOR_VERSION < 7
# define Tcl_LibraryInitProc Tcl_PackageInitProc
# define Tcl_StaticLibrary Tcl_StaticPackage
+# endif
#endif
#ifdef TCL_TEST
@@ -115,7 +118,7 @@ int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if ((Tcl_Init)(interp) == TCL_ERROR) {
+ if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -157,11 +160,11 @@ Tcl_AppInit(
*/
#ifdef DJGPP
- (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
- Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL,
+ Tcl_NewStringObj("~/tclsh.rc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
#else
- (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
- Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL,
+ Tcl_NewStringObj("~/.tclshrc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
#endif
return TCL_OK;
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 6d559d1..f5c0e8b 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -4,6 +4,9 @@
#ifndef _TCLCONFIG
#define _TCLCONFIG
+/* Define if building universal (internal helper macro) */
+#undef AC_APPLE_UNIVERSAL_BUILD
+
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
@@ -16,6 +19,9 @@
/* Defined when compiler supports casting to union type. */
#undef HAVE_CAST_TO_UNION
+/* Define to 1 if you have the `cfmakeraw' function. */
+#undef HAVE_CFMAKERAW
+
/* Define to 1 if you have the `chflags' function. */
#undef HAVE_CHFLAGS
@@ -39,9 +45,16 @@
you don't. */
#undef HAVE_DECL_GETHOSTBYNAME_R
+/* Define to 1 if you have the declaration of `PTHREAD_MUTEX_RECURSIVE', and
+ to 0 if you don't. */
+#undef HAVE_DECL_PTHREAD_MUTEX_RECURSIVE
+
/* Is 'DIR64' in <sys/types.h>? */
#undef HAVE_DIR64
+/* Is eventfd(2) supported? */
+#undef HAVE_EVENTFD
+
/* Define to 1 if you have the `freeaddrinfo' function. */
#undef HAVE_FREEADDRINFO
@@ -126,7 +139,7 @@
/* Compiler support for module scope symbols */
#undef HAVE_HIDDEN
-/* Do we have the intptr_t type? */
+/* Define to 1 if the system has the type `intptr_t'. */
#undef HAVE_INTPTR_T
/* Define to 1 if you have the <inttypes.h> header file. */
@@ -144,9 +157,6 @@
/* Define to 1 if you have the `lseek64' function. */
#undef HAVE_LSEEK64
-/* Define to 1 if you have the <memory.h> header file. */
-#undef HAVE_MEMORY_H
-
/* Define to 1 if you have the `mkstemp' function. */
#undef HAVE_MKSTEMP
@@ -174,6 +184,9 @@
/* Define to 1 if you have the `OSSpinLockLock' function. */
#undef HAVE_OSSPINLOCKLOCK
+/* Should we use pselect()? */
+#undef HAVE_PSELECT
+
/* Define to 1 if you have the `pthread_atfork' function. */
#undef HAVE_PTHREAD_ATFORK
@@ -186,9 +199,15 @@
/* Are characters signed? */
#undef HAVE_SIGNED_CHAR
+/* Do we have <stdbool.h>? */
+#undef HAVE_STDBOOL_H
+
/* Define to 1 if you have the <stdint.h> header file. */
#undef HAVE_STDINT_H
+/* Define to 1 if you have the <stdio.h> header file. */
+#undef HAVE_STDIO_H
+
/* Define to 1 if you have the <stdlib.h> header file. */
#undef HAVE_STDLIB_H
@@ -219,12 +238,21 @@
/* Is 'struct stat64' in <sys/stat.h>? */
#undef HAVE_STRUCT_STAT64
-/* Define to 1 if `st_blksize' is member of `struct stat'. */
+/* Define to 1 if `st_blksize' is a member of `struct stat'. */
#undef HAVE_STRUCT_STAT_ST_BLKSIZE
-/* Define to 1 if `st_blocks' is member of `struct stat'. */
+/* Define to 1 if `st_blocks' is a member of `struct stat'. */
#undef HAVE_STRUCT_STAT_ST_BLOCKS
+/* Define to 1 if you have the <sys/epoll.h> header file. */
+#undef HAVE_SYS_EPOLL_H
+
+/* Define to 1 if you have the <sys/eventfd.h> header file. */
+#undef HAVE_SYS_EVENTFD_H
+
+/* Define to 1 if you have the <sys/event.h> header file. */
+#undef HAVE_SYS_EVENT_H
+
/* Define to 1 if you have the <sys/filio.h> header file. */
#undef HAVE_SYS_FILIO_H
@@ -264,7 +292,7 @@
/* Is off64_t in <sys/types.h>? */
#undef HAVE_TYPE_OFF64_T
-/* Do we have the uintptr_t type? */
+/* Define to 1 if the system has the type `uintptr_t'. */
#undef HAVE_UINTPTR_T
/* Define to 1 if you have the <unistd.h> header file. */
@@ -294,6 +322,12 @@
/* Use compat implementation of getaddrinfo() and friends */
#undef NEED_FAKE_RFC2553
+/* Is epoll(7) supported? */
+#undef NOTIFIER_EPOLL
+
+/* Is kqueue(2) supported? */
+#undef NOTIFIER_KQUEUE
+
/* Is Darwin CoreFoundation unavailable for 64-bit? */
#undef NO_COREFOUNDATION_64
@@ -306,9 +340,6 @@
/* Do we have fd_set? */
#undef NO_FD_SET
-/* Do we have <float.h>? */
-#undef NO_FLOAT_H
-
/* Do we have fork() */
#undef NO_FORK
@@ -321,9 +352,6 @@
/* Do we have getwd() */
#undef NO_GETWD
-/* Do we have a usable 'isnan'? */
-#undef NO_ISNAN
-
/* Do we have memmove()? */
#undef NO_MEMMOVE
@@ -354,9 +382,6 @@
/* Do we have a usable 'union wait'? */
#undef NO_UNION_WAIT
-/* Do we have <values.h>? */
-#undef NO_VALUES_H
-
/* Do we have wait3() */
#undef NO_WAIT3
@@ -372,13 +397,18 @@
/* Define to the one symbol short name of this package. */
#undef PACKAGE_TARNAME
+/* Define to the home page for this package. */
+#undef PACKAGE_URL
+
/* Define to the version of this package. */
#undef PACKAGE_VERSION
/* Is this a static build? */
#undef STATIC_BUILD
-/* Define to 1 if you have the ANSI C header files. */
+/* Define to 1 if all of the C90 standard headers exist (not just the ones
+ required in a freestanding environment). This macro is provided for
+ backward compatibility; new code need not use it. */
#undef STDC_HEADERS
/* What encoding should be used for embedded configuration info? */
@@ -411,26 +441,17 @@
/* What is the default extension for shared libraries? */
#undef TCL_SHLIB_EXT
-/* Are we building with threads enabled? */
-#undef TCL_THREADS
-
-/* Build libtommath? */
-#undef TCL_TOMMATH
-
/* Do we allow unloading of shared libraries? */
#undef TCL_UNLOAD_DLLS
/* Does this platform have wide high-resolution clicks? */
#undef TCL_WIDE_CLICKS
-/* Are wide integers to be implemented with C 'long's? */
+/* Do 'long' and 'long long' have the same size (64-bit)? */
#undef TCL_WIDE_INT_IS_LONG
-/* What type should be used to define wide integers? */
-#undef TCL_WIDE_INT_TYPE
-
-/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
-#undef TIME_WITH_SYS_TIME
+/* Tcl with external libtommath */
+#undef TCL_WITH_EXTERNAL_TOMMATH
/* Is getcwd Posix-compliant? */
#undef USEGETWD
@@ -444,15 +465,23 @@
/* Should we use FIONBIO? */
#undef USE_FIONBIO
-/* Do we want to use the threaded memory allocator? */
-#undef USE_THREAD_ALLOC
-
/* Should we use vfork() instead of fork()? */
#undef USE_VFORK
-/* Define to 1 if your processor stores words with the most significant byte
- first (like Motorola and SPARC, unlike Intel and VAX). */
-#undef WORDS_BIGENDIAN
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+ significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+# define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+# undef WORDS_BIGENDIAN
+# endif
+#endif
+
+/* Are we building with zipfs enabled? */
+#undef ZIPFS_BUILD
/* Are Darwin SUSv3 extensions available? */
#undef _DARWIN_C_SOURCE
@@ -481,7 +510,8 @@
/* Do we want to use the XOPEN network library? */
#undef _XOPEN_SOURCE_EXTENDED
-/* Define to 1 if type `char' is unsigned and you are not using gcc. */
+/* Define to 1 if type `char' is unsigned and your compiler does not
+ predefine this macro. */
#ifndef __CHAR_UNSIGNED__
# undef __CHAR_UNSIGNED__
#endif
@@ -495,16 +525,13 @@
#undef inline
#endif
-/* Signed integer type wide enough to hold a pointer. */
-#undef intptr_t
-
/* Define to `int' if <sys/types.h> does not define. */
#undef mode_t
-/* Define to `int' if <sys/types.h> does not define. */
+/* Define as a signed integer type capable of holding a process identifier. */
#undef pid_t
-/* Define to `unsigned' if <sys/types.h> does not define. */
+/* Define to `unsigned int' if <sys/types.h> does not define. */
#undef size_t
/* Define as int if socklen_t is not available */
@@ -513,9 +540,6 @@
/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t
-/* Unsigned integer type wide enough to hold a pointer. */
-#undef uintptr_t
-
/* Undef unused package specific autoheader defines so that we can
* include both tclConfig.h and tkConfig.h at the same time: */
diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in
index f768690..f2ac768 100644
--- a/unix/tclConfig.sh.in
+++ b/unix/tclConfig.sh.in
@@ -23,7 +23,8 @@ TCL_DEFS='@DEFS@'
# TCL_DBGX used to be used to distinguish debug vs. non-debug builds.
# This was a righteous pain so the core doesn't do that any more.
-TCL_DBGX=
+# DEPRECATED, will be removed in Tcl 9!
+TCL_DBGX=''
# Default flags used in an optimized and debuggable build, respectively.
TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@'
@@ -39,6 +40,9 @@ TCL_SHARED_BUILD=@TCL_SHARED_BUILD@
# The name of the Tcl library (may be either a .a file or a shared library):
TCL_LIB_FILE='@TCL_LIB_FILE@'
+# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library):
+TCL_ZIP_FILE='@TCL_ZIP_FILE@'
+
# Additional libraries to use when linking Tcl.
TCL_LIBS='@TCL_LIBS@'
@@ -66,7 +70,7 @@ TCL_SHLIB_LD='@SHLIB_LD@'
TCL_STLIB_LD='@STLIB_LD@'
# Either '$LIBS' (if dependent libraries should be included when linking
-# shared libraries) or an empty string. See Tcl's configure.in for more
+# shared libraries) or an empty string. See Tcl's configure.ac for more
# explanation.
TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@'
@@ -164,6 +168,3 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'
-
-# Flag, 1: we built Tcl with threads enabled, 0 we didn't
-TCL_THREADS=@TCL_THREADS@
diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c
new file mode 100644
index 0000000..649c21b
--- /dev/null
+++ b/unix/tclEpollNotfy.c
@@ -0,0 +1,844 @@
+/*
+ * tclEpollNotfy.c --
+ *
+ * This file contains the implementation of the epoll()-based
+ * Linux-specific notifier, which is the lowest-level part of the Tcl
+ * event loop. This file works together with generic/tclNotify.c.
+ *
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de>
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
+ * in tclMacOSXNotify.c */
+#if defined(NOTIFIER_EPOLL) && TCL_THREADS
+#ifndef _GNU_SOURCE
+# define _GNU_SOURCE /* For pipe2(2) */
+#endif
+#include <fcntl.h>
+#include <signal.h>
+#include <sys/epoll.h>
+#ifdef HAVE_EVENTFD
+#include <sys/eventfd.h>
+#endif /* HAVE_EVENTFD */
+#include <sys/queue.h>
+
+/*
+ * This structure is used to keep track of the notifier info for a registered
+ * file.
+ */
+
+struct PlatformEventData;
+typedef struct FileHandler {
+ int fd;
+ int mask; /* Mask of desired events: TCL_READABLE,
+ * etc. */
+ int readyMask; /* Mask of events that have been seen since
+ * the last time file handlers were invoked
+ * for this file. */
+ Tcl_FileProc *proc; /* Function to call, in the style of
+ * Tcl_CreateFileHandler. */
+ ClientData clientData; /* Argument to pass to proc. */
+ struct FileHandler *nextPtr;/* Next in list of all files we care about. */
+ LIST_ENTRY(FileHandler) readyNode;
+ /* Next/previous in list of FileHandlers asso-
+ * ciated with regular files (S_IFREG) that are
+ * ready for I/O. */
+ struct PlatformEventData *pedPtr;
+ /* Pointer to PlatformEventData associating this
+ * FileHandler with epoll(7) events. */
+} FileHandler;
+
+/*
+ * The following structure associates a FileHandler and the thread that owns
+ * it with the file descriptors of interest and their event masks passed to
+ * epoll_ctl(2) and their corresponding event(s) returned by epoll_wait(2).
+ */
+
+struct ThreadSpecificData;
+struct PlatformEventData {
+ FileHandler *filePtr;
+ struct ThreadSpecificData *tsdPtr;
+};
+
+/*
+ * The following structure is what is added to the Tcl event queue when file
+ * handlers are ready to fire.
+ */
+
+typedef struct {
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ int fd; /* File descriptor that is ready. Used to find
+ * the FileHandler structure for the file
+ * (can't point directly to the FileHandler
+ * structure because it could go away while
+ * the event is queued). */
+} FileHandlerEvent;
+
+/*
+ * The following static structure contains the state information for the
+ * epoll based implementation of the Tcl notifier. One of these structures is
+ * created for each thread that is using the notifier.
+ */
+
+LIST_HEAD(PlatformReadyFileHandlerList, FileHandler);
+typedef struct ThreadSpecificData {
+ FileHandler *triggerFilePtr;
+ FileHandler *firstFileHandlerPtr;
+ /* Pointer to head of file handler list. */
+ struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr;
+ /* Pointer to head of list of FileHandlers
+ * associated with regular files (S_IFREG)
+ * that are ready for I/O. */
+ pthread_mutex_t notifierMutex;
+ /* Mutex protecting notifier termination in
+ * TclpFinalizeNotifier. */
+#ifdef HAVE_EVENTFD
+ int triggerEventFd; /* eventfd(2) used by other threads to wake
+ * up this thread for inter-thread IPC. */
+#else
+ int triggerPipe[2]; /* pipe(2) used by other threads to wake
+ * up this thread for inter-thread IPC. */
+#endif /* HAVE_EVENTFD */
+ int eventsFd; /* epoll(7) file descriptor used to wait for
+ * fds */
+ struct epoll_event *readyEvents;
+ /* Pointer to at most maxReadyEvents events
+ * returned by epoll_wait(2). */
+ size_t maxReadyEvents; /* Count of epoll_events in readyEvents. */
+ int asyncPending; /* True when signal triggered thread. */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * Forward declarations.
+ */
+
+static void PlatformEventsControl(FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr, int op, int isNew);
+static void PlatformEventsInit(void);
+static int PlatformEventsTranslate(struct epoll_event *event);
+static int PlatformEventsWait(struct epoll_event *events,
+ size_t numEvents, struct timeval *timePtr);
+
+/*
+ * Incorporate the base notifier implementation.
+ */
+
+#include "tclUnixNotfy.c"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpInitNotifier --
+ *
+ * Initializes the platform specific notifier state.
+ *
+ * Results:
+ * Returns a handle to the notifier state for this thread.
+ *
+ * Side effects:
+ * If no initNotifierProc notifier hook exists, PlatformEventsInit is
+ * called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpInitNotifier(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ PlatformEventsInit();
+ return tsdPtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsControl --
+ *
+ * This function registers interest for the file descriptor and the mask
+ * of TCL_* bits associated with filePtr on the epoll file descriptor
+ * associated with tsdPtr.
+ *
+ * Future calls to epoll_wait will return filePtr and tsdPtr alongside
+ * with the event registered here via the PlatformEventData struct.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * - If adding a new file descriptor, a PlatformEventData struct will be
+ * allocated and associated with filePtr.
+ * - fstat is called on the file descriptor; if it is associated with a
+ * regular file (S_IFREG,) filePtr is considered to be ready for I/O
+ * and added to or deleted from the corresponding list in tsdPtr.
+ * - If it is not associated with a regular file, the file descriptor is
+ * added, modified concerning its mask of events of interest, or
+ * deleted from the epoll file descriptor of the calling thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PlatformEventsControl(
+ FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr,
+ int op,
+ int isNew)
+{
+ struct epoll_event newEvent;
+ struct PlatformEventData *newPedPtr;
+ Tcl_StatBuf fdStat;
+
+ newEvent.events = 0;
+ if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
+ newEvent.events |= EPOLLIN;
+ }
+ if (filePtr->mask & TCL_WRITABLE) {
+ newEvent.events |= EPOLLOUT;
+ }
+ if (isNew) {
+ newPedPtr = (struct PlatformEventData *)
+ ckalloc(sizeof(struct PlatformEventData));
+ newPedPtr->filePtr = filePtr;
+ newPedPtr->tsdPtr = tsdPtr;
+ filePtr->pedPtr = newPedPtr;
+ }
+ newEvent.data.ptr = filePtr->pedPtr;
+
+ /*
+ * N.B. As discussed in Tcl_WaitForEvent(), epoll(7) does not support
+ * regular files (S_IFREG). Therefore, filePtr is in these cases simply
+ * added or deleted from the list of FileHandlers associated with regular
+ * files belonging to tsdPtr.
+ */
+
+ if (TclOSfstat(filePtr->fd, &fdStat) == -1) {
+ Tcl_Panic("fstat: %s", strerror(errno));
+ }
+
+ if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) {
+ switch (errno) {
+ case EPERM:
+ switch (op) {
+ case EPOLL_CTL_ADD:
+ if (isNew) {
+ LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr,
+ readyNode);
+ }
+ break;
+ case EPOLL_CTL_DEL:
+ LIST_REMOVE(filePtr, readyNode);
+ break;
+
+ }
+ break;
+ default:
+ Tcl_Panic("epoll_ctl: %s", strerror(errno));
+ }
+ }
+ return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeNotifier --
+ *
+ * This function closes the eventfd and the epoll file descriptor and
+ * frees the epoll_event structs owned by the thread of the caller. The
+ * above operations are protected by tsdPtr->notifierMutex, which is
+ * destroyed thereafter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * While tsdPtr->notifierMutex is held:
+ * - The per-thread eventfd(2) is closed, if non-zero, and set to -1.
+ * - The per-thread epoll(7) fd is closed, if non-zero, and set to 0.
+ * - The per-thread epoll_event structs are freed, if any, and set to 0.
+ *
+ * tsdPtr->notifierMutex is destroyed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeNotifier(
+ TCL_UNUSED(ClientData))
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ pthread_mutex_lock(&tsdPtr->notifierMutex);
+#ifdef HAVE_EVENTFD
+ if (tsdPtr->triggerEventFd) {
+ close(tsdPtr->triggerEventFd);
+ tsdPtr->triggerEventFd = -1;
+ }
+#else /* !HAVE_EVENTFD */
+ if (tsdPtr->triggerPipe[0]) {
+ close(tsdPtr->triggerPipe[0]);
+ tsdPtr->triggerPipe[0] = -1;
+ }
+ if (tsdPtr->triggerPipe[1]) {
+ close(tsdPtr->triggerPipe[1]);
+ tsdPtr->triggerPipe[1] = -1;
+ }
+#endif /* HAVE_EVENTFD */
+ ckfree(tsdPtr->triggerFilePtr->pedPtr);
+ ckfree(tsdPtr->triggerFilePtr);
+ if (tsdPtr->eventsFd > 0) {
+ close(tsdPtr->eventsFd);
+ tsdPtr->eventsFd = 0;
+ }
+ if (tsdPtr->readyEvents) {
+ ckfree(tsdPtr->readyEvents);
+ tsdPtr->maxReadyEvents = 0;
+ }
+ pthread_mutex_unlock(&tsdPtr->notifierMutex);
+ if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) {
+ Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsInit --
+ *
+ * This function abstracts creating a kqueue fd via the epoll_create
+ * system call and allocating memory for the epoll_event structs in
+ * tsdPtr for the thread of the caller.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The following per-thread entities are initialised:
+ * - notifierMutex is initialised.
+ * - The eventfd(2) is created w/ EFD_CLOEXEC and EFD_NONBLOCK.
+ * - The epoll(7) fd is created w/ EPOLL_CLOEXEC.
+ * - A FileHandler struct is allocated and initialised for the
+ * eventfd(2), registering interest for TCL_READABLE on it via
+ * PlatformEventsControl().
+ * - readyEvents and maxReadyEvents are initialised with 512
+ * epoll_events.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PlatformEventsInit(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr;
+
+ errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
+ if (errno) {
+ Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
+ }
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+#ifdef HAVE_EVENTFD
+ tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK);
+ if (tsdPtr->triggerEventFd <= 0) {
+ Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger eventfd");
+ }
+ filePtr->fd = tsdPtr->triggerEventFd;
+#else /* !HAVE_EVENTFD */
+ if (pipe2(tsdPtr->triggerPipe, O_CLOEXEC | O_NONBLOCK) != 0) {
+ Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe");
+ }
+ filePtr->fd = tsdPtr->triggerPipe[0];
+#endif /* HAVE_EVENTFD */
+ tsdPtr->triggerFilePtr = filePtr;
+ if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
+ Tcl_Panic("epoll_create1: %s", strerror(errno));
+ }
+ filePtr->mask = TCL_READABLE;
+ PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
+ if (!tsdPtr->readyEvents) {
+ tsdPtr->maxReadyEvents = 512;
+ tsdPtr->readyEvents = (struct epoll_event *) ckalloc(
+ tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
+ }
+ LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsTranslate --
+ *
+ * This function translates the platform-specific mask of returned events
+ * in eventPtr to a mask of TCL_* bits.
+ *
+ * Results:
+ * Returns the translated mask.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PlatformEventsTranslate(
+ struct epoll_event *eventPtr)
+{
+ int mask;
+
+ mask = 0;
+ if (eventPtr->events & (EPOLLIN | EPOLLHUP)) {
+ mask |= TCL_READABLE;
+ }
+ if (eventPtr->events & EPOLLOUT) {
+ mask |= TCL_WRITABLE;
+ }
+ if (eventPtr->events & EPOLLERR) {
+ mask |= TCL_EXCEPTION;
+ }
+ return mask;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsWait --
+ *
+ * This function abstracts waiting for I/O events via epoll_wait.
+ *
+ * Results:
+ * Returns -1 if epoll_wait failed. Returns 0 if polling and if no events
+ * became available whilst polling. Returns a pointer to and the count of
+ * all returned events in all other cases.
+ *
+ * Side effects:
+ * gettimeofday(2), epoll_wait(2), and gettimeofday(2) are called, in the
+ * specified order.
+ * If timePtr specifies a positive value, it is updated to reflect the
+ * amount of time that has passed; if its value would {under, over}flow,
+ * it is set to zero.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PlatformEventsWait(
+ struct epoll_event *events,
+ size_t numEvents,
+ struct timeval *timePtr)
+{
+ int numFound;
+ struct timeval tv0, tv1, tv_delta;
+ int timeout;
+
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * If timePtr is NULL, epoll_wait(2) will wait indefinitely. If it
+ * specifies a timeout of {0,0}, epoll_wait(2) will poll. Otherwise, the
+ * timeout will simply be converted to milliseconds.
+ */
+
+ if (!timePtr) {
+ timeout = -1;
+ } else if (!timePtr->tv_sec && !timePtr->tv_usec) {
+ timeout = 0;
+ } else {
+ timeout = (int) timePtr->tv_sec * 1000;
+ if (timePtr->tv_usec) {
+ timeout += (int) timePtr->tv_usec / 1000;
+ }
+ }
+
+ /*
+ * Call (and possibly block on) epoll_wait(2) and substract the delta of
+ * gettimeofday(2) before and after the call from timePtr if the latter is
+ * not NULL. Return the number of events returned by epoll_wait(2).
+ */
+
+ gettimeofday(&tv0, NULL);
+ numFound = epoll_wait(tsdPtr->eventsFd, events, (int) numEvents, timeout);
+ gettimeofday(&tv1, NULL);
+ if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) {
+ timersub(&tv1, &tv0, &tv_delta);
+ if (!timercmp(&tv_delta, timePtr, >)) {
+ timersub(timePtr, &tv_delta, timePtr);
+ } else {
+ timePtr->tv_sec = 0;
+ timePtr->tv_usec = 0;
+ }
+ }
+ if (tsdPtr->asyncPending) {
+ tsdPtr->asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
+ return numFound;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateFileHandler --
+ *
+ * This function registers a file handler with the epoll notifier of the
+ * thread of the caller.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new file handler structure.
+ * PlatformEventsControl() is called for the new file handler structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpCreateFileHandler(
+ 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. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
+ int isNew = (filePtr == NULL);
+
+ if (isNew) {
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+ filePtr->fd = fd;
+ filePtr->readyMask = 0;
+ filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
+ tsdPtr->firstFileHandlerPtr = filePtr;
+ }
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+ filePtr->mask = mask;
+
+ PlatformEventsControl(filePtr, tsdPtr,
+ isNew ? EPOLL_CTL_ADD : EPOLL_CTL_MOD, isNew);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpDeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for a file on the
+ * epoll file descriptor of the thread of the caller.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on file, remove it.
+ * PlatformEventsControl() is called for the file handler structure.
+ * The PlatformEventData struct associated with the new file handler
+ * structure is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpDeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ FileHandler *filePtr, *prevPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Find the entry for the given file (and return if there isn't one).
+ */
+
+ filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr);
+ if (filePtr == NULL) {
+ return;
+ }
+
+ /*
+ * Update the check masks for this file.
+ */
+
+ PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0);
+ if (filePtr->pedPtr) {
+ ckfree(filePtr->pedPtr);
+ }
+
+ /*
+ * Clean up information in the callback record.
+ */
+
+ if (prevPtr == NULL) {
+ tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = filePtr->nextPtr;
+ }
+ ckfree(filePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpWaitForEvent --
+ *
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the message queue. If the block time is 0, then TclpWaitForEvent just
+ * polls without blocking.
+ *
+ * The waiting logic is implemented in PlatformEventsWait.
+ *
+ * Results:
+ * Returns -1 if PlatformEventsWait() would block forever, otherwise
+ * returns 0.
+ *
+ * Side effects:
+ * Queues file events that are detected by PlatformEventsWait().
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpWaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ FileHandler *filePtr;
+ Tcl_Time vTime;
+ struct timeval timeout, *timeoutPtr;
+ /* Impl. notes: timeout & timeoutPtr are used
+ * if, and only if threads are not enabled.
+ * They are the arguments for the regular
+ * epoll_wait() used when the core is not
+ * thread-enabled. */
+ int mask, numFound, numEvent;
+ struct PlatformEventData *pedPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int numQueued;
+ ssize_t i;
+
+ /*
+ * Set up the timeout structure. Note that if there are no events to check
+ * for, we return with a negative result rather than blocking forever.
+ */
+
+ if (timePtr != NULL) {
+ /*
+ * TIP #233 (Virtualized Time). Is virtual time in effect? And do we
+ * actually have something to scale? If yes to both then we call the
+ * handler to do this scaling.
+ */
+
+ if (timePtr->sec != 0 || timePtr->usec != 0) {
+ vTime = *timePtr;
+ TclScaleTime(&vTime);
+ timePtr = &vTime;
+ }
+ timeout.tv_sec = timePtr->sec;
+ timeout.tv_usec = timePtr->usec;
+ timeoutPtr = &timeout;
+ } else {
+ timeoutPtr = NULL;
+ }
+
+ /*
+ * Walk the list of FileHandlers associated with regular files (S_IFREG)
+ * belonging to tsdPtr, queue Tcl events for them, and update their mask
+ * of events of interest.
+ *
+ * As epoll(7) does not support regular files, the behaviour of
+ * {select,poll}(2) is simply simulated here: fds associated with regular
+ * files are added to this list by PlatformEventsControl() and processed
+ * here before calling (and possibly blocking) on PlatformEventsWait().
+ */
+
+ numQueued = 0;
+ LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) {
+ mask = 0;
+ if (filePtr->mask & TCL_READABLE) {
+ mask |= TCL_READABLE;
+ }
+ if (filePtr->mask & TCL_WRITABLE) {
+ mask |= TCL_WRITABLE;
+ }
+
+ /*
+ * Don't bother to queue an event if the mask was previously non-zero
+ * since an event must still be on the queue.
+ */
+
+ if (filePtr->readyMask == 0) {
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
+ ckalloc(sizeof(FileHandlerEvent));
+
+ fileEvPtr->header.proc = FileHandlerEventProc;
+ fileEvPtr->fd = filePtr->fd;
+ Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
+ numQueued++;
+ }
+ filePtr->readyMask = mask;
+ }
+
+ /*
+ * If any events were queued in the above loop, force PlatformEventsWait()
+ * to poll as there already are events that need to be processed at this
+ * point.
+ */
+
+ if (numQueued) {
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 0;
+ timeoutPtr = &timeout;
+ }
+
+ /*
+ * Wait or poll for new events, queue Tcl events for the FileHandlers
+ * corresponding to them, and update the FileHandlers' mask of events of
+ * interest registered by the last call to Tcl_CreateFileHandler().
+ *
+ * Events for the eventfd(2)/trigger pipe are processed here in order to
+ * facilitate inter-thread IPC. If another thread intends to wake up this
+ * thread whilst it's blocking on PlatformEventsWait(), it write(2)s to
+ * the eventfd(2)/trigger pipe (see Tcl_AlertNotifier(),) which in turn
+ * will cause PlatformEventsWait() to return immediately.
+ */
+
+ numFound = PlatformEventsWait(tsdPtr->readyEvents,
+ tsdPtr->maxReadyEvents, timeoutPtr);
+ for (numEvent = 0; numEvent < numFound; numEvent++) {
+ pedPtr = (struct PlatformEventData *)
+ tsdPtr->readyEvents[numEvent].data.ptr;
+ filePtr = pedPtr->filePtr;
+ mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
+#ifdef HAVE_EVENTFD
+ if (filePtr->fd == tsdPtr->triggerEventFd) {
+ uint64_t eventFdVal;
+
+ i = read(tsdPtr->triggerEventFd, &eventFdVal, sizeof(eventFdVal));
+ if ((i != sizeof(eventFdVal)) && (errno != EAGAIN)) {
+ Tcl_Panic("%s: read from %p->triggerEventFd: %s",
+ "Tcl_WaitForEvent", (void *) tsdPtr, strerror(errno));
+ }
+ continue;
+ }
+#else /* !HAVE_EVENTFD */
+ if (filePtr->fd == tsdPtr->triggerPipe[0]) {
+ char triggerPipeVal;
+
+ i = read(tsdPtr->triggerPipe[0], &triggerPipeVal,
+ sizeof(triggerPipeVal));
+ if ((i != sizeof(triggerPipeVal)) && (errno != EAGAIN)) {
+ Tcl_Panic("%s: read from %p->triggerPipe[0]: %s",
+ "Tcl_WaitForEvent", (void *) tsdPtr, strerror(errno));
+ }
+ continue;
+ }
+#endif /* HAVE_EVENTFD */
+ if (!mask) {
+ continue;
+ }
+
+ /*
+ * Don't bother to queue an event if the mask was previously non-zero
+ * since an event must still be on the queue.
+ */
+
+ if (filePtr->readyMask == 0) {
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
+ ckalloc(sizeof(FileHandlerEvent));
+
+ fileEvPtr->header.proc = FileHandlerEventProc;
+ fileEvPtr->fd = filePtr->fd;
+ Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
+ }
+ filePtr->readyMask = mask;
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclAsyncNotifier --
+ *
+ * This procedure sets the async mark of an async handler to a
+ * given value, if it is called from the target thread.
+ *
+ * Result:
+ * True, when the handler will be marked, false otherwise.
+ *
+ * Side effects:
+ * The signal may be resent to the target thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclAsyncNotifier(
+ int sigNumber, /* Signal number. */
+ Tcl_ThreadId threadId, /* Target thread. */
+ ClientData 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) threadId)) {
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+
+ *flagPtr = value;
+ if (tsdPtr != NULL && !tsdPtr->asyncPending) {
+ tsdPtr->asyncPending = 1;
+ TclpAlertNotifier(tsdPtr);
+ return 1;
+ }
+ return 0;
+ }
+
+ /*
+ * Re-send the signal to the proper target thread.
+ */
+
+ pthread_kill((pthread_t) threadId, sigNumber);
+#else
+ (void)sigNumber;
+ (void)threadId;
+ (void)clientData;
+ (void)flagPtr;
+ (void)value;
+#endif
+ return 0;
+}
+
+#endif /* NOTIFIER_EPOLL && TCL_THREADS */
+#else
+TCL_MAC_EMPTY_FILE(unix_tclEpollNotfy_c)
+#endif /* !HAVE_COREFOUNDATION */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/unix/tclKqueueNotfy.c b/unix/tclKqueueNotfy.c
new file mode 100644
index 0000000..2f495bd
--- /dev/null
+++ b/unix/tclKqueueNotfy.c
@@ -0,0 +1,840 @@
+/*
+ * tclKqueueNotfy.c --
+ *
+ * This file contains the implementation of the kqueue()-based
+ * DragonFly/Free/Net/OpenBSD-specific notifier, which is the lowest-
+ * level part of the Tcl event loop. This file works together with
+ * generic/tclNotify.c.
+ *
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de>
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
+ * in tclMacOSXNotify.c */
+#if defined(NOTIFIER_KQUEUE) && TCL_THREADS
+
+#include <signal.h>
+#include <sys/types.h>
+#include <sys/event.h>
+#include <sys/queue.h>
+#include <sys/time.h>
+
+/*
+ * This structure is used to keep track of the notifier info for a registered
+ * file.
+ */
+
+struct PlatformEventData;
+typedef struct FileHandler {
+ int fd; /* File descriptor that this is describing a
+ * handler for. */
+ int mask; /* Mask of desired events: TCL_READABLE,
+ * etc. */
+ int readyMask; /* Mask of events that have been seen since
+ * the last time file handlers were invoked
+ * for this file. */
+ Tcl_FileProc *proc; /* Function to call, in the style of
+ * Tcl_CreateFileHandler. */
+ ClientData clientData; /* Argument to pass to proc. */
+ struct FileHandler *nextPtr;/* Next in list of all files we care about. */
+ LIST_ENTRY(FileHandler) readyNode;
+ /* Next/previous in list of FileHandlers asso-
+ * ciated with regular files (S_IFREG) that are
+ * ready for I/O. */
+ struct PlatformEventData *pedPtr;
+ /* Pointer to PlatformEventData associating this
+ * FileHandler with kevent(2) events. */
+} FileHandler;
+
+/*
+ * The following structure associates a FileHandler and the thread that owns
+ * it with the file descriptors of interest and their event masks passed to
+ * kevent(2) and their corresponding event(s) returned by kevent(2).
+ */
+
+struct ThreadSpecificData;
+struct PlatformEventData {
+ FileHandler *filePtr;
+ struct ThreadSpecificData *tsdPtr;
+};
+
+/*
+ * The following structure is what is added to the Tcl event queue when file
+ * handlers are ready to fire.
+ */
+
+typedef struct {
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ int fd; /* File descriptor that is ready. Used to find
+ * the FileHandler structure for the file
+ * (can't point directly to the FileHandler
+ * structure because it could go away while
+ * the event is queued). */
+} FileHandlerEvent;
+
+/*
+ * The following static structure contains the state information for the
+ * kqueue based implementation of the Tcl notifier. One of these structures is
+ * created for each thread that is using the notifier.
+ */
+
+LIST_HEAD(PlatformReadyFileHandlerList, FileHandler);
+typedef struct ThreadSpecificData {
+ FileHandler *firstFileHandlerPtr;
+ /* Pointer to head of file handler list. */
+ struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr;
+ /* Pointer to head of list of FileHandlers
+ * associated with regular files (S_IFREG)
+ * that are ready for I/O. */
+ pthread_mutex_t notifierMutex;
+ /* Mutex protecting notifier termination in
+ * TclpFinalizeNotifier. */
+ int triggerPipe[2]; /* pipe(2) used by other threads to wake
+ * up this thread for inter-thread IPC. */
+ int eventsFd; /* kqueue(2) file descriptor used to wait for
+ * fds. */
+ struct kevent *readyEvents; /* Pointer to at most maxReadyEvents events
+ * returned by kevent(2). */
+ size_t maxReadyEvents; /* Count of kevents in readyEvents. */
+ int asyncPending; /* True when signal triggered thread. */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * Forward declarations of internal functions.
+ */
+
+static void PlatformEventsControl(FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr, int op, int isNew);
+static int PlatformEventsTranslate(struct kevent *eventPtr);
+static int PlatformEventsWait(struct kevent *events,
+ size_t numEvents, struct timeval *timePtr);
+
+/*
+ * Incorporate the base notifier implementation.
+ */
+
+#include "tclUnixNotfy.c"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsControl --
+ *
+ * This function registers interest for the file descriptor and the mask
+ * of TCL_* bits associated with filePtr on the kqueue file descriptor
+ * associated with tsdPtr.
+ *
+ * Future calls to kevent will return filePtr and tsdPtr alongside with
+ * the event registered here via the PlatformEventData struct.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * - If adding a new file descriptor, a PlatformEventData struct will be
+ * allocated and associated with filePtr.
+ * - fstat is called on the file descriptor; if it is associated with
+ * a regular file (S_IFREG,) filePtr is considered to be ready for I/O
+ * and added to or deleted from the corresponding list in tsdPtr.
+ * - If it is not associated with a regular file, the file descriptor is
+ * added, modified concerning its mask of events of interest, or
+ * deleted from the epoll file descriptor of the calling thread.
+ * - If deleting a file descriptor, kevent(2) is called twice specifying
+ * EVFILT_READ first and then EVFILT_WRITE (see note below.)
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PlatformEventsControl(
+ FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr,
+ int op,
+ int isNew)
+{
+ int numChanges;
+ struct kevent changeList[2];
+ struct PlatformEventData *newPedPtr;
+ Tcl_StatBuf fdStat;
+
+ if (isNew) {
+ newPedPtr = (struct PlatformEventData *)
+ ckalloc(sizeof(struct PlatformEventData));
+ newPedPtr->filePtr = filePtr;
+ newPedPtr->tsdPtr = tsdPtr;
+ filePtr->pedPtr = newPedPtr;
+ }
+
+ /*
+ * N.B. As discussed in Tcl_WaitForEvent(), kqueue(2) does not reproduce
+ * the `always ready' {select,poll}(2) behaviour for regular files
+ * (S_IFREG) prior to FreeBSD 11.0-RELEASE. Therefore, filePtr is in these
+ * cases simply added or deleted from the list of FileHandlers associated
+ * with regular files belonging to tsdPtr.
+ */
+
+ if (TclOSfstat(filePtr->fd, &fdStat) == -1) {
+ Tcl_Panic("fstat: %s", strerror(errno));
+ } else if ((fdStat.st_mode & S_IFMT) == S_IFREG
+ || (fdStat.st_mode & S_IFMT) == S_IFDIR
+ || (fdStat.st_mode & S_IFMT) == S_IFLNK
+ ) {
+ switch (op) {
+ case EV_ADD:
+ if (isNew) {
+ LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr,
+ readyNode);
+ }
+ break;
+ case EV_DELETE:
+ LIST_REMOVE(filePtr, readyNode);
+ break;
+ }
+ return;
+ }
+
+ numChanges = 0;
+ switch (op) {
+ case EV_ADD:
+ if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
+ EV_SET(&changeList[numChanges], (uintptr_t) filePtr->fd,
+ EVFILT_READ, op, 0, 0, filePtr->pedPtr);
+ numChanges++;
+ }
+ if (filePtr->mask & TCL_WRITABLE) {
+ EV_SET(&changeList[numChanges], (uintptr_t) filePtr->fd,
+ EVFILT_WRITE, op, 0, 0, filePtr->pedPtr);
+ numChanges++;
+ }
+ if (numChanges) {
+ if (kevent(tsdPtr->eventsFd, changeList, numChanges, NULL, 0,
+ NULL) == -1) {
+ Tcl_Panic("kevent: %s", strerror(errno));
+ }
+ }
+ break;
+ case EV_DELETE:
+ /*
+ * N.B. kqueue(2) has separate filters for readability and writability
+ * fd events. We therefore need to ensure that fds are ompletely
+ * removed from the kqueue(2) fd when deleting. This is exacerbated
+ * by changes to filePtr->mask w/o calls to PlatforEventsControl()
+ * after e.g. an exec(3) in a child process.
+ *
+ * As one of these calls can fail, two separate kevent(2) calls are
+ * made for EVFILT_{READ,WRITE}.
+ */
+ EV_SET(&changeList[0], (uintptr_t) filePtr->fd, EVFILT_READ, op, 0, 0,
+ NULL);
+ if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1)
+ && (errno != ENOENT)) {
+ Tcl_Panic("kevent: %s", strerror(errno));
+ }
+ EV_SET(&changeList[0], (uintptr_t) filePtr->fd, EVFILT_WRITE, op, 0, 0,
+ NULL);
+ if ((kevent(tsdPtr->eventsFd, changeList, 1, NULL, 0, NULL) == -1)
+ && (errno != ENOENT)) {
+ Tcl_Panic("kevent: %s", strerror(errno));
+ }
+ break;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeNotifier --
+ *
+ * This function closes the pipe and the kqueue file descriptors and
+ * frees the kevent structs owned by the thread of the caller. The above
+ * operations are protected by tsdPtr->notifierMutex, which is destroyed
+ * thereafter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * While tsdPtr->notifierMutex is held:
+ * The per-thread pipe(2) fds are closed, if non-zero, and set to -1.
+ * The per-thread kqueue(2) fd is closed, if non-zero, and set to 0.
+ * The per-thread kevent structs are freed, if any, and set to 0.
+ *
+ * tsdPtr->notifierMutex is destroyed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeNotifier(
+ TCL_UNUSED(ClientData))
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ pthread_mutex_lock(&tsdPtr->notifierMutex);
+ if (tsdPtr->triggerPipe[0]) {
+ close(tsdPtr->triggerPipe[0]);
+ tsdPtr->triggerPipe[0] = -1;
+ }
+ if (tsdPtr->triggerPipe[1]) {
+ close(tsdPtr->triggerPipe[1]);
+ tsdPtr->triggerPipe[1] = -1;
+ }
+ if (tsdPtr->eventsFd > 0) {
+ close(tsdPtr->eventsFd);
+ tsdPtr->eventsFd = 0;
+ }
+ if (tsdPtr->readyEvents) {
+ ckfree(tsdPtr->readyEvents);
+ tsdPtr->maxReadyEvents = 0;
+ }
+ pthread_mutex_unlock(&tsdPtr->notifierMutex);
+ if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) {
+ Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpInitNotifier --
+ *
+ * Initializes the platform specific notifier state.
+ *
+ * This function abstracts creating a kqueue fd via the kqueue system
+ * call and allocating memory for the kevents structs in tsdPtr for the
+ * thread of the caller.
+ *
+ * Results:
+ * Returns a handle to the notifier state for this thread.
+ *
+ * Side effects:
+ * The following per-thread entities are initialised:
+ * - notifierMutex is initialised.
+ * - The pipe(2) is created; fcntl(2) is called on both fds to set
+ * FD_CLOEXEC and O_NONBLOCK.
+ * - The kqueue(2) fd is created; fcntl(2) is called on it to set
+ * FD_CLOEXEC.
+ * - A FileHandler struct is allocated and initialised for the event-
+ * fd(2), registering interest for TCL_READABLE on it via Platform-
+ * EventsControl().
+ * - readyEvents and maxReadyEvents are initialised with 512 kevents.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpInitNotifier(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int i, fdFl;
+ FileHandler *filePtr;
+
+ errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
+ if (errno) {
+ Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
+ }
+ if (pipe(tsdPtr->triggerPipe) != 0) {
+ Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe");
+ } else for (i = 0; i < 2; i++) {
+ if (fcntl(tsdPtr->triggerPipe[i], F_SETFD, FD_CLOEXEC) == -1) {
+ Tcl_Panic("fcntl: %s", strerror(errno));
+ } else {
+ fdFl = fcntl(tsdPtr->triggerPipe[i], F_GETFL);
+ fdFl |= O_NONBLOCK;
+ }
+ if (fcntl(tsdPtr->triggerPipe[i], F_SETFL, fdFl) == -1) {
+ Tcl_Panic("fcntl: %s", strerror(errno));
+ }
+ }
+ if ((tsdPtr->eventsFd = kqueue()) == -1) {
+ Tcl_Panic("kqueue: %s", strerror(errno));
+ } else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
+ Tcl_Panic("fcntl: %s", strerror(errno));
+ }
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+ filePtr->fd = tsdPtr->triggerPipe[0];
+ filePtr->mask = TCL_READABLE;
+ PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1);
+ if (!tsdPtr->readyEvents) {
+ tsdPtr->maxReadyEvents = 512;
+ tsdPtr->readyEvents = (struct kevent *) ckalloc(
+ tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
+ }
+ LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
+
+ return tsdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsTranslate --
+ *
+ * This function translates the platform-specific mask of returned
+ * events in eventPtr to a mask of TCL_* bits.
+ *
+ * Results:
+ * Returns the translated mask.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PlatformEventsTranslate(
+ struct kevent *eventPtr)
+{
+ int mask;
+
+ mask = 0;
+ if (eventPtr->filter == EVFILT_READ) {
+ mask |= TCL_READABLE;
+ if (eventPtr->flags & EV_ERROR) {
+ mask |= TCL_EXCEPTION;
+ }
+ }
+ if (eventPtr->filter == EVFILT_WRITE) {
+ mask |= TCL_WRITABLE;
+ if (eventPtr->flags & EV_ERROR) {
+ mask |= TCL_EXCEPTION;
+ }
+ }
+ return mask;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsWait --
+ *
+ * This function abstracts waiting for I/O events via the kevent system
+ * call.
+ *
+ * Results:
+ * Returns -1 if kevent failed. Returns 0 if polling and if no events
+ * became available whilst polling. Returns a pointer to and the count of
+ * all returned events in all other cases.
+ *
+ * Side effects:
+ * gettimeofday(2), kevent(2), and gettimeofday(2) are called, in the
+ * specified order.
+ * If timePtr specifies a positive value, it is updated to reflect the
+ * amount of time that has passed; if its value would {under, over}flow,
+ * it is set to zero.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PlatformEventsWait(
+ struct kevent *events,
+ size_t numEvents,
+ struct timeval *timePtr)
+{
+ int numFound;
+ struct timeval tv0, tv1, tv_delta;
+ struct timespec timeout, *timeoutPtr;
+
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * If timePtr is NULL, kevent(2) will wait indefinitely. If it specifies a
+ * timeout of {0,0}, kevent(2) will poll. Otherwise, the timeout will
+ * simply be converted to a timespec.
+ */
+
+ if (!timePtr) {
+ timeoutPtr = NULL;
+ } else if (!timePtr->tv_sec && !timePtr->tv_usec) {
+ timeout.tv_sec = 0;
+ timeout.tv_nsec = 0;
+ timeoutPtr = &timeout;
+ } else {
+ timeout.tv_sec = timePtr->tv_sec;
+ timeout.tv_nsec = timePtr->tv_usec * 1000;
+ timeoutPtr = &timeout;
+ }
+
+ /*
+ * Call (and possibly block on) kevent(2) and substract the delta of
+ * gettimeofday(2) before and after the call from timePtr if the latter is
+ * not NULL. Return the number of events returned by kevent(2).
+ */
+
+ gettimeofday(&tv0, NULL);
+ numFound = kevent(tsdPtr->eventsFd, NULL, 0, events, (int) numEvents,
+ timeoutPtr);
+ gettimeofday(&tv1, NULL);
+ if (timePtr && (timePtr->tv_sec && timePtr->tv_usec)) {
+ timersub(&tv1, &tv0, &tv_delta);
+ if (!timercmp(&tv_delta, timePtr, >)) {
+ timersub(timePtr, &tv_delta, timePtr);
+ } else {
+ timePtr->tv_sec = 0;
+ timePtr->tv_usec = 0;
+ }
+ }
+ if (tsdPtr->asyncPending) {
+ tsdPtr->asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
+ return numFound;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateFileHandler --
+ *
+ * This function registers a file handler with the kqueue notifier
+ * of the thread of the caller.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new file handler structure.
+ * PlatformEventsControl() is called for the new file handler structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpCreateFileHandler(
+ 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. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
+ int isNew = (filePtr == NULL);
+
+ if (isNew) {
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+ filePtr->fd = fd;
+ filePtr->readyMask = 0;
+ filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
+ tsdPtr->firstFileHandlerPtr = filePtr;
+ }
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+ filePtr->mask = mask;
+
+ PlatformEventsControl(filePtr, tsdPtr, EV_ADD, isNew);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpDeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for a file on the
+ * kqueue of the thread of the caller.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on file, remove it.
+ * PlatformEventsControl() is called for the file handler structure.
+ * The PlatformEventData struct associated with the new file handler
+ * structure is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpDeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr, *prevPtr;
+
+ /*
+ * Find the entry for the given file (and return if there isn't one).
+ */
+
+ filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr);
+ if (filePtr == NULL) {
+ return;
+ }
+
+ /*
+ * Update the check masks for this file.
+ */
+
+ PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0);
+ if (filePtr->pedPtr) {
+ ckfree(filePtr->pedPtr);
+ }
+
+ /*
+ * Clean up information in the callback record.
+ */
+
+ if (prevPtr == NULL) {
+ tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = filePtr->nextPtr;
+ }
+ ckfree(filePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpWaitForEvent --
+ *
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the message queue. If the block time is 0, then TclpWaitForEvent just
+ * polls without blocking.
+ *
+ * The waiting logic is implemented in PlatformEventsWait.
+ *
+ * Results:
+ * Returns -1 if PlatformEventsWait() would block forever, otherwise
+ * returns 0.
+ *
+ * Side effects:
+ * Queues file events that are detected by PlatformEventsWait().
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpWaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ FileHandler *filePtr;
+ int mask;
+ Tcl_Time vTime;
+ struct timeval timeout, *timeoutPtr;
+ /* Impl. notes: timeout & timeoutPtr are used
+ * if, and only if threads are not enabled.
+ * They are the arguments for the regular
+ * epoll_wait() used when the core is not
+ * thread-enabled. */
+ int numFound, numEvent;
+ struct PlatformEventData *pedPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int numQueued;
+ ssize_t i;
+ char buf[1];
+
+ /*
+ * Set up the timeout structure. Note that if there are no events to check
+ * for, we return with a negative result rather than blocking forever.
+ */
+
+ if (timePtr != NULL) {
+ /*
+ * TIP #233 (Virtualized Time). Is virtual time in effect? And do we
+ * actually have something to scale? If yes to both then we call the
+ * handler to do this scaling.
+ */
+
+ if (timePtr->sec != 0 || timePtr->usec != 0) {
+ vTime = *timePtr;
+ TclScaleTime(&vTime);
+ timePtr = &vTime;
+ }
+ timeout.tv_sec = timePtr->sec;
+ timeout.tv_usec = timePtr->usec;
+ timeoutPtr = &timeout;
+ } else {
+ timeoutPtr = NULL;
+ }
+
+ /*
+ * Walk the list of FileHandlers associated with regular files (S_IFREG)
+ * belonging to tsdPtr, queue Tcl events for them, and update their mask
+ * of events of interest.
+ *
+ * kqueue(2), unlike epoll(7), does support regular files, but EVFILT_READ
+ * only `[r]eturns when the file pointer is not at the end of file' as
+ * opposed to unconditionally. While FreeBSD 11.0-RELEASE adds support for
+ * this mode (NOTE_FILE_POLL,) this is not used for reasons of
+ * compatibility.
+ *
+ * Therefore, the behaviour of {select,poll}(2) is simply simulated here:
+ * fds associated with regular files are added to this list by
+ * PlatformEventsControl() and processed here before calling (and possibly
+ * blocking) on PlatformEventsWait().
+ */
+
+ numQueued = 0;
+ LIST_FOREACH(filePtr, &tsdPtr->firstReadyFileHandlerPtr, readyNode) {
+ mask = 0;
+ if (filePtr->mask & TCL_READABLE) {
+ mask |= TCL_READABLE;
+ }
+ if (filePtr->mask & TCL_WRITABLE) {
+ mask |= TCL_WRITABLE;
+ }
+
+ /*
+ * Don't bother to queue an event if the mask was previously non-zero
+ * since an event must still be on the queue.
+ */
+
+ if (filePtr->readyMask == 0) {
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
+ ckalloc(sizeof(FileHandlerEvent));
+
+ fileEvPtr->header.proc = FileHandlerEventProc;
+ fileEvPtr->fd = filePtr->fd;
+ Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
+ numQueued++;
+ }
+ filePtr->readyMask = mask;
+ }
+
+ /*
+ * If any events were queued in the above loop, force PlatformEventsWait()
+ * to poll as there already are events that need to be processed at this
+ * point.
+ */
+
+ if (numQueued) {
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 0;
+ timeoutPtr = &timeout;
+ }
+
+ /*
+ * Wait or poll for new events, queue Tcl events for the FileHandlers
+ * corresponding to them, and update the FileHandlers' mask of events of
+ * interest registered by the last call to Tcl_CreateFileHandler().
+ *
+ * Events for the trigger pipe are processed here in order to facilitate
+ * inter-thread IPC. If another thread intends to wake up this thread
+ * whilst it's blocking on PlatformEventsWait(), it write(2)s to the other
+ * end of the pipe (see Tcl_AlertNotifier(),) which in turn will cause
+ * PlatformEventsWait() to return immediately.
+ */
+
+ numFound = PlatformEventsWait(tsdPtr->readyEvents,
+ tsdPtr->maxReadyEvents, timeoutPtr);
+ for (numEvent = 0; numEvent < numFound; numEvent++) {
+ pedPtr = (struct PlatformEventData *)
+ tsdPtr->readyEvents[numEvent].udata;
+ filePtr = pedPtr->filePtr;
+ mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
+ if (filePtr->fd == tsdPtr->triggerPipe[0]) {
+ i = read(tsdPtr->triggerPipe[0], buf, 1);
+ if ((i == -1) && (errno != EAGAIN)) {
+ Tcl_Panic("Tcl_WaitForEvent: read from %p->triggerPipe: %s",
+ (void *) tsdPtr, strerror(errno));
+ }
+ continue;
+ }
+ if (!mask) {
+ continue;
+ }
+
+ /*
+ * Don't bother to queue an event if the mask was previously non-zero
+ * since an event must still be on the queue.
+ */
+
+ if (filePtr->readyMask == 0) {
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
+ ckalloc(sizeof(FileHandlerEvent));
+
+ fileEvPtr->header.proc = FileHandlerEventProc;
+ fileEvPtr->fd = filePtr->fd;
+ Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
+ }
+ filePtr->readyMask |= mask;
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclAsyncNotifier --
+ *
+ * This procedure sets the async mark of an async handler to a
+ * given value, if it is called from the target thread.
+ *
+ * Result:
+ * True, when the handler will be marked, false otherwise.
+ *
+ * Side effects:
+ * The signal may be resent to the target thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclAsyncNotifier(
+ int sigNumber, /* Signal number. */
+ Tcl_ThreadId threadId, /* Target thread. */
+ ClientData 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) threadId)) {
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+
+ *flagPtr = value;
+ if (tsdPtr != NULL && !tsdPtr->asyncPending) {
+ tsdPtr->asyncPending = 1;
+ TclpAlertNotifier(tsdPtr);
+ return 1;
+ }
+ return 0;
+ }
+
+ /*
+ * Re-send the signal to the proper target thread.
+ */
+
+ pthread_kill((pthread_t) threadId, sigNumber);
+#else
+ (void)sigNumber;
+ (void)threadId;
+ (void)clientData;
+ (void)flagPtr;
+ (void)value;
+#endif
+ return 0;
+}
+
+#endif /* NOTIFIER_KQUEUE && TCL_THREADS */
+#else
+TCL_MAC_EMPTY_FILE(unix_tclKqueueNotfy_c)
+#endif /* !HAVE_COREFOUNDATION */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/unix/tclLoadAix.c b/unix/tclLoadAix.c
index fea9494..17fca04 100644
--- a/unix/tclLoadAix.c
+++ b/unix/tclLoadAix.c
@@ -9,7 +9,7 @@
* different from the notice used elsewhere in Tcl. The file has been
* modified to incorporate the file dlfcn.h in-line.
*
- * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH
+ * Copyright © 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH
* Not derived from licensed software.
*
* Permission is granted to freely use, copy, modify, and redistribute
@@ -23,7 +23,7 @@
/*
* @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38
- * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH
+ * This is an unpublished work copyright © 1992 HELIOS Software GmbH
* 30159 Hannover, Germany
*/
diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index aec071c..afceafd 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -4,7 +4,7 @@
* This procedure provides a version of the TclLoadFile that works with
* the "dlopen" and "dlsym" library procedures for dynamic loading.
*
- * 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.
@@ -83,7 +83,7 @@ TclpDlopen(
* relative path.
*/
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const char *)Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
@@ -108,7 +108,7 @@ TclpDlopen(
Tcl_DString ds;
const char *fileName = Tcl_GetString(pathPtr);
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
@@ -131,7 +131,7 @@ TclpDlopen(
}
return TCL_ERROR;
}
- newHandle = ckalloc(sizeof(*newHandle));
+ newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
@@ -179,15 +179,40 @@ FindSymbol(
* the underscore.
*/
- native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds);
proc = dlsym(handle, native); /* INTL: Native. */
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
- native = Tcl_DStringAppend(&newName, native, -1);
+ native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
+#ifdef __cplusplus
+ if (proc == NULL) {
+ char buf[32];
+ snprintf(buf, sizeof(buf), "%d", Tcl_DStringLength(&ds));
+ Tcl_DStringInit(&newName);
+ TclDStringAppendLiteral(&newName, "__Z");
+ Tcl_DStringAppend(&newName, buf, TCL_INDEX_NONE);
+ Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), TCL_INDEX_NONE);
+ TclDStringAppendLiteral(&newName, "P10Tcl_Interp");
+ native = Tcl_DStringValue(&newName);
+ proc = dlsym(handle, native + 1); /* INTL: Native. */
+ if (proc == NULL) {
+ proc = dlsym(handle, native); /* INTL: Native. */
+ }
+ if (proc == NULL) {
+ TclDStringAppendLiteral(&newName, "i");
+ native = Tcl_DStringValue(&newName);
+ proc = dlsym(handle, native + 1); /* INTL: Native. */
+ }
+ if (proc == NULL) {
+ proc = dlsym(handle, native); /* INTL: Native. */
+ }
+ Tcl_DStringFree(&newName);
+ }
+#endif
Tcl_DStringFree(&ds);
if (proc == NULL) {
const char *errorStr = dlerror();
@@ -210,15 +235,14 @@ FindSymbol(
*
* UnloadFile --
*
- * Unloads a dynamically loaded binary code file from memory. Code
- * pointers in the formerly loaded file are no longer valid after calling
- * this function.
+ * Unloads a dynamic shared object, after which all pointers to functions
+ * in the formerly-loaded object are no longer valid.
*
* Results:
* None.
*
* Side effects:
- * Code removed from memory.
+ * Memory for the loaded object is deallocated.
*
*----------------------------------------------------------------------
*/
@@ -236,36 +260,6 @@ UnloadFile(
}
/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index 7d462da..854d4bd 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -6,8 +6,8 @@
* Original version of his file (superseded long ago) provided by
* Wilfredo Sanchez (wsanchez@apple.com).
*
- * Copyright (c) 1995 Apple Computer, Inc.
- * Copyright (c) 2001-2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 1995 Apple Computer, Inc.
+ * Copyright © 2001-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.
@@ -183,9 +183,9 @@ TclpDlopen(
* relative path.
*/
- nativePath = Tcl_FSGetNativePath(pathPtr);
+ nativePath = (const char *)Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr),
- -1, &ds);
+ TCL_INDEX_NONE, &ds);
#if TCL_DYLD_USE_DLFCN
/*
@@ -258,7 +258,7 @@ TclpDlopen(
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
- modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
+ modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
} else {
@@ -278,13 +278,13 @@ TclpDlopen(
|| dyldLibHeader || modulePtr
#endif /* TCL_DYLD_USE_NSMODULE */
) {
- dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
+ dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = dlHandle;
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
- newHandle = ckalloc(sizeof(*newHandle));
+ newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
@@ -296,7 +296,7 @@ TclpDlopen(
TclNewObj(errObj);
if (errMsg != NULL) {
- Tcl_AppendToObj(errObj, errMsg, -1);
+ Tcl_AppendToObj(errObj, errMsg, TCL_INDEX_NONE);
}
#if TCL_DYLD_USE_NSMODULE
if (objFileImageErrMsg) {
@@ -335,16 +335,16 @@ FindSymbol(
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
const char *symbol) /* Symbol name to look up. */
{
- Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
- Tcl_PackageInitProc *proc = NULL;
+ Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
+ Tcl_LibraryInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
- native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds);
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
- proc = dlsym(dyldLoadHandle->dlHandle, native);
+ proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
@@ -360,7 +360,7 @@ FindSymbol(
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
- native = Tcl_DStringAppend(&newName, native, -1);
+ native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE);
if (dyldLoadHandle->dyldLibHeader) {
nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader,
native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
@@ -382,7 +382,7 @@ FindSymbol(
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
- modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
+ modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = dyldLoadHandle->modulePtr;
dyldLoadHandle->modulePtr = modulePtr;
@@ -400,7 +400,7 @@ FindSymbol(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
- proc = NSAddressOfSymbol(nsSymbol);
+ proc = (Tcl_LibraryInitProc *)NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
@@ -412,7 +412,7 @@ FindSymbol(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
- return proc;
+ return (void *)proc;
}
/*
@@ -441,7 +441,7 @@ UnloadFile(
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
- Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
+ Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
@@ -468,36 +468,6 @@ UnloadFile(
/*
*----------------------------------------------------------------------
*
- * 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclpLoadMemoryGetBuffer --
*
* Allocate a buffer that can be used with TclpLoadMemory() below.
@@ -514,7 +484,7 @@ TclGuessPackageName(
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
int size) /* Size of desired buffer. */
{
void *buffer = NULL;
@@ -589,7 +559,7 @@ TclpLoadMemory(
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
- const struct fat_header *fh = buffer;
+ const struct fat_header *fh = (const struct fat_header *)buffer;
uint32_t ms = 0;
#ifndef __LP64__
const struct mach_header *mh = NULL;
@@ -618,18 +588,18 @@ TclpLoadMemory(
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
- swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
+ swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
}
fa = NXFindBestFatArch(arch->cputype | arch_abi,
- arch->cpusubtype, fatarchs, fh_nfat_arch);
+ arch->cpusubtype, (struct fat_arch *)fatarchs, fh_nfat_arch);
if (fa) {
- mh = (void *)((char *) buffer + fa->offset);
+ mh = (const struct mach_header_64 *)((char *) buffer + fa->offset);
ms = fa->size;
} else {
err = NSObjectFileImageInappropriateFile;
}
if (fh->magic != FAT_MAGIC) {
- swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
+ swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
}
} else {
err = NSObjectFileImageInappropriateFile;
@@ -639,7 +609,7 @@ TclpLoadMemory(
* Thin binary
*/
- mh = buffer;
+ mh = (const struct mach_header_64 *)buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
@@ -686,7 +656,7 @@ TclpLoadMemory(
const char *errorName, *errMsg;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE));
return TCL_ERROR;
}
@@ -694,14 +664,14 @@ TclpLoadMemory(
* Stash the module reference within the load handle we create and return.
*/
- modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
+ modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
- dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
+ dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = NULL;
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
- newHandle = ckalloc(sizeof(*newHandle));
+ newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c
index eb0affa..dc827fc 100644
--- a/unix/tclLoadNext.c
+++ b/unix/tclLoadNext.c
@@ -4,7 +4,7 @@
* This procedure provides a version of the TclLoadFile that works with
* NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich.
*
- * 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.
@@ -83,7 +83,7 @@ TclpDlopen(
Tcl_DString ds;
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
files = {native,NULL};
result = rld_load(errorStream, &header, files, NULL);
Tcl_DStringFree(&ds);
@@ -101,7 +101,7 @@ TclpDlopen(
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
- newHandle = ckalloc(sizeof(Tcl_LoadHandle));
+ newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
newHandle->clientData = INT2PTR(1);
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
@@ -133,7 +133,7 @@ FindSymbol(
Tcl_LoadHandle loadHandle,
const char *symbol)
{
- Tcl_PackageInitProc *proc = NULL;
+ Tcl_LibraryInitProc *proc = NULL;
if (symbol) {
char sym[strlen(symbol) + 2];
@@ -179,36 +179,6 @@ UnloadFile(
}
/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c
index 377ed28..03698fa 100644
--- a/unix/tclLoadOSF.c
+++ b/unix/tclLoadOSF.c
@@ -26,7 +26,7 @@
*
* John Robert LoVerso <loverso@freebsd.osf.org>
*
- * 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.
@@ -89,7 +89,7 @@ TclpDlopen(
*/
native = Tcl_FSGetNativePath(pathPtr);
- lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
+ lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS);
if (lm == LDR_NULL_MODULE) {
/*
@@ -100,8 +100,8 @@ TclpDlopen(
Tcl_DString ds;
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
- lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
+ native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
+ lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS);
Tcl_DStringFree(&ds);
}
@@ -128,7 +128,7 @@ TclpDlopen(
} else {
pkg++;
}
- newHandle = ckalloc(sizeof(*newHandle));
+ newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = pkg;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
@@ -197,36 +197,6 @@ UnloadFile(
}
/*
- *----------------------------------------------------------------------
- *
- * TclGuessPackageName --
- *
- * If the "load" command is invoked without providing a package name,
- * this function 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;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c
index 4be3d7b..5cde183 100644
--- a/unix/tclLoadShl.c
+++ b/unix/tclLoadShl.c
@@ -5,7 +5,7 @@
* the "shl_load" and "shl_findsym" library procedures for dynamic
* loading (e.g. for HP machines).
*
- * 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.
@@ -86,7 +86,7 @@ TclpDlopen(
Tcl_DString ds;
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
Tcl_DStringFree(&ds);
}
@@ -97,7 +97,7 @@ TclpDlopen(
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
- newHandle = ckalloc(sizeof(*newHandle));
+ newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
@@ -128,7 +128,7 @@ FindSymbol(
const char *symbol)
{
Tcl_DString newName;
- Tcl_PackageInitProc *proc = NULL;
+ Tcl_LibraryInitProc *proc = NULL;
shl_t handle = (shl_t) loadHandle->clientData;
/*
@@ -140,7 +140,7 @@ FindSymbol(
(void *) &proc) != 0) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
- Tcl_DStringAppend(&newName, symbol, -1);
+ Tcl_DStringAppend(&newName, symbol, TCL_INDEX_NONE);
if (shl_findsym(&handle, Tcl_DStringValue(&newName),
(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
proc = NULL;
@@ -186,36 +186,6 @@ UnloadFile(
}
/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c
new file mode 100644
index 0000000..fc77e77
--- /dev/null
+++ b/unix/tclSelectNotfy.c
@@ -0,0 +1,1233 @@
+/*
+ * tclSelectNotfy.c --
+ *
+ * This file contains the implementation of the select()-based generic
+ * Unix notifier, which is the lowest-level part of the Tcl event loop.
+ * This file works together with generic/tclNotify.c.
+ *
+ * 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.
+ */
+
+#include "tclInt.h"
+#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
+ * in tclMacOSXNotify.c */
+#if (!defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE)) || !TCL_THREADS
+
+#include <signal.h>
+
+/*
+ * This structure is used to keep track of the notifier info for a registered
+ * file.
+ */
+
+typedef struct FileHandler {
+ int fd;
+ int mask; /* Mask of desired events: TCL_READABLE,
+ * etc. */
+ int readyMask; /* Mask of events that have been seen since
+ * the last time file handlers were invoked
+ * for this file. */
+ Tcl_FileProc *proc; /* Function to call, in the style of
+ * Tcl_CreateFileHandler. */
+ ClientData clientData; /* Argument to pass to proc. */
+ struct FileHandler *nextPtr;/* Next in list of all files we care about. */
+} FileHandler;
+
+/*
+ * The following structure contains a set of select() masks to track readable,
+ * writable, and exception conditions.
+ */
+
+typedef struct {
+ fd_set readable;
+ fd_set writable;
+ fd_set exception;
+} SelectMasks;
+
+/*
+ * The following structure is what is added to the Tcl event queue when file
+ * handlers are ready to fire.
+ */
+
+typedef struct {
+ Tcl_Event header; /* Information that is standard for all
+ * events. */
+ int fd; /* File descriptor that is ready. Used to find
+ * the FileHandler structure for the file
+ * (can't point directly to the FileHandler
+ * structure because it could go away while
+ * the event is queued). */
+} FileHandlerEvent;
+
+/*
+ * The following static structure contains the state information for the
+ * select based implementation of the Tcl notifier. One of these structures is
+ * created for each thread that is using the notifier.
+ */
+
+typedef struct ThreadSpecificData {
+ FileHandler *firstFileHandlerPtr;
+ /* Pointer to head of file handler list. */
+ SelectMasks checkMasks; /* This structure is used to build up the
+ * masks to be used in the next call to
+ * select. Bits are set in response to calls
+ * to Tcl_CreateFileHandler. */
+ SelectMasks readyMasks; /* This array reflects the readable/writable
+ * conditions that were found to exist by the
+ * last call to select. */
+ int numFdBits; /* Number of valid bits in checkMasks (one
+ * more than highest fd for which
+ * Tcl_WatchFile has been called). */
+#if TCL_THREADS
+ int onList; /* True if it is in this list */
+ unsigned int pollState; /* pollState is used to implement a polling
+ * handshake between each thread and the
+ * notifier thread. Bits defined below. */
+ struct ThreadSpecificData *nextPtr, *prevPtr;
+ /* All threads that are currently waiting on
+ * an event have their ThreadSpecificData
+ * structure on a doubly-linked listed formed
+ * from these pointers. You must hold the
+ * notifierMutex lock before accessing these
+ * fields. */
+#ifdef __CYGWIN__
+ void *event; /* Any other thread alerts a notifier that an
+ * event is ready to be processed by sending
+ * this event. */
+ void *hwnd; /* Messaging window. */
+#else /* !__CYGWIN__ */
+ pthread_cond_t waitCV; /* Any other thread alerts a notifier that an
+ * event is ready to be processed by signaling
+ * this condition variable. */
+#endif /* __CYGWIN__ */
+ int waitCVinitialized; /* Variable to flag initialization of the
+ * structure. */
+ int eventReady; /* True if an event is ready to be processed.
+ * Used as condition flag together with waitCV
+ * above. */
+#endif /* TCL_THREADS */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+#if TCL_THREADS
+/*
+ * The following static indicates the number of threads that have initialized
+ * notifiers.
+ *
+ * You must hold the notifierMutex lock before accessing this variable.
+ */
+
+static int notifierCount = 0;
+
+/*
+ * The following variable points to the head of a doubly-linked list of
+ * ThreadSpecificData structures for all threads that are currently waiting on
+ * an event.
+ *
+ * You must hold the notifierMutex lock before accessing this list.
+ */
+
+static ThreadSpecificData *waitingListPtr = NULL;
+
+/*
+ * The notifier thread spends all its time in select() waiting for a file
+ * descriptor associated with one of the threads on the waitingListPtr list to
+ * do something interesting. But if the contents of the waitingListPtr list
+ * ever changes, we need to wake up and restart the select() system call. You
+ * can wake up the notifier thread by writing a single byte to the file
+ * descriptor defined below. This file descriptor is the input-end of a pipe
+ * and the notifier thread is listening for data on the output-end of the same
+ * pipe. Hence writing to this file descriptor will cause the select() system
+ * call to return and wake up the notifier thread.
+ *
+ * You must hold the notifierMutex lock before writing to the pipe.
+ */
+
+static int triggerPipe = -1;
+static int otherPipe = -1;
+
+/*
+ * The notifierMutex locks access to all of the global notifier state.
+ */
+
+static pthread_mutex_t notifierInitMutex = PTHREAD_MUTEX_INITIALIZER;
+static pthread_mutex_t notifierMutex = PTHREAD_MUTEX_INITIALIZER;
+/*
+ * The following static indicates if the notifier thread is running.
+ *
+ * You must hold the notifierInitMutex before accessing this variable.
+ */
+
+static int notifierThreadRunning = 0;
+
+/*
+ * The following static flag indicates that async handlers are pending.
+ */
+
+static int asyncPending = 0;
+
+/*
+ * The notifier thread signals the notifierCV when it has finished
+ * initializing the triggerPipe and right before the notifier thread
+ * terminates. This condition is used to deal with the signal mask, too.
+ */
+
+static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER;
+
+/*
+ * The pollState bits:
+ *
+ * POLL_WANT is set by each thread before it waits on its condition variable.
+ * It is checked by the notifier before it does select.
+ *
+ * POLL_DONE is set by the notifier if it goes into select after seeing
+ * POLL_WANT. The idea is to ensure it tries a select with the same bits
+ * the initial thread had set.
+ */
+
+#define POLL_WANT 0x1
+#define POLL_DONE 0x2
+
+/*
+ * This is the thread ID of the notifier thread that does select.
+ */
+
+static Tcl_ThreadId notifierThread;
+
+/*
+ * Signal mask information for notifier thread.
+ */
+
+static sigset_t notifierSigMask;
+#ifndef HAVE_PSELECT
+static sigset_t allSigMask;
+#endif /* HAVE_PSELECT */
+
+#endif /* TCL_THREADS */
+
+/*
+ * Static routines defined in this file.
+ */
+
+#if TCL_THREADS
+static TCL_NORETURN void NotifierThreadProc(ClientData clientData);
+#if defined(HAVE_PTHREAD_ATFORK)
+static int atForkInit = 0;
+static void AtForkChild(void);
+#endif /* HAVE_PTHREAD_ATFORK */
+#endif /* TCL_THREADS */
+static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
+
+/*
+ * Import of critical bits of Windows API when building threaded with Cygwin.
+ */
+
+#if defined(__CYGWIN__)
+#ifdef __cplusplus
+extern "C" {
+#endif
+typedef struct {
+ void *hwnd; /* Messaging window. */
+ unsigned int *message; /* Message payload. */
+ size_t wParam; /* Event-specific "word" parameter. */
+ size_t lParam; /* Event-specific "long" parameter. */
+ int time; /* Event timestamp. */
+ int x; /* Event location (where meaningful). */
+ int y;
+ int lPrivate;
+} MSG;
+
+typedef struct {
+ unsigned int style;
+ void *lpfnWndProc;
+ int cbClsExtra;
+ int cbWndExtra;
+ void *hInstance;
+ void *hIcon;
+ void *hCursor;
+ void *hbrBackground;
+ const void *lpszMenuName;
+ const void *lpszClassName;
+} WNDCLASSW;
+
+#ifdef __clang__
+#pragma clang diagnostic ignored "-Wignored-attributes"
+#endif
+extern void __stdcall CloseHandle(void *);
+extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
+ void *);
+extern void *__stdcall CreateWindowExW(void *, const void *, const void *,
+ unsigned int, int, int, int, int, void *, void *,
+ void *, void *);
+extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *);
+extern unsigned char __stdcall DestroyWindow(void *);
+extern int __stdcall DispatchMessageW(const MSG *);
+extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
+extern void __stdcall MsgWaitForMultipleObjects(unsigned int, void *,
+ unsigned char, unsigned int, unsigned int);
+extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
+extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *,
+ void *);
+extern void __stdcall PostQuitMessage(int);
+extern void *__stdcall RegisterClassW(const WNDCLASSW *);
+extern unsigned char __stdcall ResetEvent(void *);
+extern unsigned char __stdcall TranslateMessage(const MSG *);
+
+/*
+ * Threaded-cygwin specific constants and functions in this file:
+ */
+
+#if TCL_THREADS && defined(__CYGWIN__)
+static const wchar_t className[] = L"TclNotifier";
+static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
+ void *wParam, void *lParam);
+#endif /* TCL_THREADS && defined(__CYGWIN__) */
+#ifdef __cplusplus
+}
+#endif
+#endif /* TCL_THREADS && __CYGWIN__ */
+
+/*
+ * Incorporate the base notifier implementation.
+ */
+
+#include "tclUnixNotfy.c"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpInitNotifier --
+ *
+ * Initializes the platform specific notifier state.
+ *
+ * Results:
+ * Returns a handle to the notifier state for this thread.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpInitNotifier(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+#if TCL_THREADS
+ tsdPtr->eventReady = 0;
+
+ /*
+ * Initialize thread specific condition variable for this thread.
+ */
+
+ if (tsdPtr->waitCVinitialized == 0) {
+#ifdef __CYGWIN__
+ WNDCLASSW clazz;
+
+ clazz.style = 0;
+ clazz.cbClsExtra = 0;
+ clazz.cbWndExtra = 0;
+ clazz.hInstance = TclWinGetTclInstance();
+ clazz.hbrBackground = NULL;
+ clazz.lpszMenuName = NULL;
+ clazz.lpszClassName = className;
+ clazz.lpfnWndProc = (void *) NotifierProc;
+ clazz.hIcon = NULL;
+ clazz.hCursor = NULL;
+
+ RegisterClassW(&clazz);
+ tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName,
+ clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
+ clazz.hInstance, NULL);
+ tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
+ 0 /* !signaled */, NULL);
+#else /* !__CYGWIN__ */
+ pthread_cond_init(&tsdPtr->waitCV, NULL);
+#endif /* __CYGWIN__ */
+ tsdPtr->waitCVinitialized = 1;
+ }
+
+ pthread_mutex_lock(&notifierInitMutex);
+#if defined(HAVE_PTHREAD_ATFORK)
+ /*
+ * Install pthread_atfork handlers to clean up the notifier in the child
+ * of a fork.
+ */
+
+ if (!atForkInit) {
+ int result = pthread_atfork(NULL, NULL, AtForkChild);
+
+ if (result) {
+ Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
+ }
+ atForkInit = 1;
+ }
+#endif /* HAVE_PTHREAD_ATFORK */
+
+ notifierCount++;
+ pthread_mutex_unlock(&notifierInitMutex);
+#endif /* TCL_THREADS */
+
+ return tsdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeNotifier --
+ *
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May terminate the background notifier thread if this is the last
+ * notifier instance.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeNotifier(
+ TCL_UNUSED(void *))
+{
+#if TCL_THREADS
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ pthread_mutex_lock(&notifierInitMutex);
+ notifierCount--;
+
+ /*
+ * If this is the last thread to use the notifier, close the notifier pipe
+ * and wait for the background thread to terminate.
+ */
+
+ if (notifierCount == 0 && triggerPipe != -1) {
+ if (write(triggerPipe, "q", 1) != 1) {
+ Tcl_Panic("Tcl_FinalizeNotifier: %s",
+ "unable to write 'q' to triggerPipe");
+ }
+ close(triggerPipe);
+ pthread_mutex_lock(&notifierMutex);
+ while(triggerPipe != -1) {
+ pthread_cond_wait(&notifierCV, &notifierMutex);
+ }
+ pthread_mutex_unlock(&notifierMutex);
+ if (notifierThreadRunning) {
+ int result = pthread_join((pthread_t) notifierThread, NULL);
+
+ if (result) {
+ Tcl_Panic("Tcl_FinalizeNotifier: %s",
+ "unable to join notifier thread");
+ }
+ notifierThreadRunning = 0;
+
+ /*
+ * If async marks are outstanding, perform actions now.
+ */
+ if (asyncPending) {
+ asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
+ }
+ }
+
+ /*
+ * Clean up any synchronization objects in the thread local storage.
+ */
+
+#ifdef __CYGWIN__
+ DestroyWindow(tsdPtr->hwnd);
+ CloseHandle(tsdPtr->event);
+#else /* !__CYGWIN__ */
+ pthread_cond_destroy(&tsdPtr->waitCV);
+#endif /* __CYGWIN__ */
+ tsdPtr->waitCVinitialized = 0;
+
+ pthread_mutex_unlock(&notifierInitMutex);
+#endif /* TCL_THREADS */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateFileHandler --
+ *
+ * This function registers a file handler with the select notifier.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new file handler structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpCreateFileHandler(
+ 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. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
+
+ if (filePtr == NULL) {
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+ filePtr->fd = fd;
+ filePtr->readyMask = 0;
+ filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
+ tsdPtr->firstFileHandlerPtr = filePtr;
+ }
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+ filePtr->mask = mask;
+
+ /*
+ * Update the check masks for this file.
+ */
+
+ if (mask & TCL_READABLE) {
+ FD_SET(fd, &tsdPtr->checkMasks.readable);
+ } else {
+ FD_CLR(fd, &tsdPtr->checkMasks.readable);
+ }
+ if (mask & TCL_WRITABLE) {
+ FD_SET(fd, &tsdPtr->checkMasks.writable);
+ } else {
+ FD_CLR(fd, &tsdPtr->checkMasks.writable);
+ }
+ if (mask & TCL_EXCEPTION) {
+ FD_SET(fd, &tsdPtr->checkMasks.exception);
+ } else {
+ FD_CLR(fd, &tsdPtr->checkMasks.exception);
+ }
+ if (tsdPtr->numFdBits <= fd) {
+ tsdPtr->numFdBits = fd + 1;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpDeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for a file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on file, remove it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpDeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr, *prevPtr;
+ int i;
+
+ /*
+ * Find the entry for the given file (and return if there isn't one).
+ */
+
+ filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr);
+ if (filePtr == NULL) {
+ return;
+ }
+
+ /*
+ * Update the check masks for this file.
+ */
+
+ if (filePtr->mask & TCL_READABLE) {
+ FD_CLR(fd, &tsdPtr->checkMasks.readable);
+ }
+ if (filePtr->mask & TCL_WRITABLE) {
+ FD_CLR(fd, &tsdPtr->checkMasks.writable);
+ }
+ if (filePtr->mask & TCL_EXCEPTION) {
+ FD_CLR(fd, &tsdPtr->checkMasks.exception);
+ }
+
+ /*
+ * Find current max fd.
+ */
+
+ if (fd + 1 == tsdPtr->numFdBits) {
+ int numFdBits = 0;
+
+ 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.exception)) {
+ numFdBits = i + 1;
+ break;
+ }
+ }
+ tsdPtr->numFdBits = numFdBits;
+ }
+
+ /*
+ * Clean up information in the callback record.
+ */
+
+ if (prevPtr == NULL) {
+ tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = filePtr->nextPtr;
+ }
+ ckfree(filePtr);
+}
+
+#if TCL_THREADS && defined(__CYGWIN__)
+
+static unsigned int __stdcall
+NotifierProc(
+ void *hwnd,
+ unsigned int message,
+ void *wParam,
+ void *lParam)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (message != 1024) {
+ return DefWindowProcW(hwnd, message, wParam, lParam);
+ }
+
+ /*
+ * Process all of the runnable events.
+ */
+
+ tsdPtr->eventReady = 1;
+ Tcl_ServiceAll();
+ return 0;
+}
+#endif /* TCL_THREADS && __CYGWIN__ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
+ * polls without blocking.
+ *
+ * Results:
+ * Returns -1 if the select would block forever, otherwise returns 0.
+ *
+ * Side effects:
+ * Queues file events that are detected by the select.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpWaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ FileHandler *filePtr;
+ int mask;
+ Tcl_Time vTime;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+#if TCL_THREADS
+ int waitForFiles;
+# ifdef __CYGWIN__
+ MSG msg;
+# endif /* __CYGWIN__ */
+#else /* !TCL_THREADS */
+ /*
+ * Impl. notes: timeout & timeoutPtr are used if, and only if threads are
+ * not enabled. They are the arguments for the regular select() used when
+ * the core is not thread-enabled.
+ */
+
+ struct timeval timeout, *timeoutPtr;
+ int numFound;
+#endif /* TCL_THREADS */
+
+ /*
+ * Set up the timeout structure. Note that if there are no events to check
+ * for, we return with a negative result rather than blocking forever.
+ */
+
+ if (timePtr != NULL) {
+ /*
+ * TIP #233 (Virtualized Time). Is virtual time in effect? And do we
+ * actually have something to scale? If yes to both then we call the
+ * handler to do this scaling.
+ */
+
+ if (timePtr->sec != 0 || timePtr->usec != 0) {
+ vTime = *timePtr;
+ TclScaleTime(&vTime);
+ timePtr = &vTime;
+ }
+#if !TCL_THREADS
+ timeout.tv_sec = timePtr->sec;
+ timeout.tv_usec = timePtr->usec;
+ timeoutPtr = &timeout;
+ } else if (tsdPtr->numFdBits == 0) {
+ /*
+ * If there are no threads, no timeout, and no fds registered, then
+ * there are no events possible and we must avoid deadlock. Note that
+ * this is not entirely correct because there might be a signal that
+ * could interrupt the select call, but we don't handle that case if
+ * we aren't using threads.
+ */
+
+ return -1;
+ } else {
+ timeoutPtr = NULL;
+#endif /* !TCL_THREADS */
+ }
+
+#if TCL_THREADS
+ /*
+ * Start notifier thread and place this thread on the list of interested
+ * threads, signal the notifier thread, and wait for a response or a
+ * timeout.
+ */
+
+ StartNotifierThread("Tcl_WaitForEvent");
+
+ pthread_mutex_lock(&notifierMutex);
+
+ if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0
+#if defined(__APPLE__) && defined(__LP64__)
+ /*
+ * 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.
+ * [Bug 1457797]
+ */
+ || timePtr->usec < 10
+#endif /* __APPLE__ && __LP64__ */
+ )) {
+ /*
+ * Cannot emulate a polling select with a polling condition variable.
+ * Instead, pretend to wait for files and tell the notifier thread
+ * what we are doing. The notifier thread makes sure it goes through
+ * select with its select mask in the same state as ours currently is.
+ * We block until that happens.
+ */
+
+ waitForFiles = 1;
+ tsdPtr->pollState = POLL_WANT;
+ timePtr = NULL;
+ } else {
+ waitForFiles = (tsdPtr->numFdBits > 0);
+ tsdPtr->pollState = 0;
+ }
+
+ if (waitForFiles) {
+ /*
+ * Add the ThreadSpecificData structure of this thread to the list of
+ * ThreadSpecificData structures of all threads that are waiting on
+ * file events.
+ */
+
+ tsdPtr->nextPtr = waitingListPtr;
+ if (waitingListPtr) {
+ waitingListPtr->prevPtr = tsdPtr;
+ }
+ tsdPtr->prevPtr = 0;
+ waitingListPtr = tsdPtr;
+ tsdPtr->onList = 1;
+
+ if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
+ Tcl_Panic("Tcl_WaitForEvent: %s",
+ "unable to write to triggerPipe");
+ }
+ }
+
+ FD_ZERO(&tsdPtr->readyMasks.readable);
+ FD_ZERO(&tsdPtr->readyMasks.writable);
+ FD_ZERO(&tsdPtr->readyMasks.exception);
+
+ if (!tsdPtr->eventReady) {
+#ifdef __CYGWIN__
+ if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
+ unsigned int timeout;
+
+ if (timePtr) {
+ timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
+ } else {
+ timeout = 0xFFFFFFFF;
+ }
+ pthread_mutex_unlock(&notifierMutex);
+ MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
+ pthread_mutex_lock(&notifierMutex);
+ }
+#else /* !__CYGWIN__ */
+ if (timePtr != NULL) {
+ Tcl_Time now;
+ struct timespec ptime;
+
+ Tcl_GetTime(&now);
+ ptime.tv_sec = timePtr->sec + now.sec +
+ (timePtr->usec + now.usec) / 1000000;
+ ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
+
+ pthread_cond_timedwait(&tsdPtr->waitCV, &notifierMutex, &ptime);
+ } else {
+ pthread_cond_wait(&tsdPtr->waitCV, &notifierMutex);
+ }
+#endif /* __CYGWIN__ */
+ }
+ tsdPtr->eventReady = 0;
+
+#ifdef __CYGWIN__
+ while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
+ /*
+ * Retrieve and dispatch the message.
+ */
+
+ unsigned int result = GetMessageW(&msg, NULL, 0, 0);
+
+ if (result == 0) {
+ PostQuitMessage(msg.wParam);
+ /* What to do here? */
+ } else if (result != (unsigned int) -1) {
+ TranslateMessage(&msg);
+ DispatchMessageW(&msg);
+ }
+ }
+ ResetEvent(tsdPtr->event);
+#endif /* __CYGWIN__ */
+
+ if (waitForFiles && tsdPtr->onList) {
+ /*
+ * Remove the ThreadSpecificData structure of this thread from the
+ * waiting list. Alert the notifier thread to recompute its select
+ * masks - skipping this caused a hang when trying to close a pipe
+ * which the notifier thread was still doing a select on.
+ */
+
+ if (tsdPtr->prevPtr) {
+ tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
+ } else {
+ waitingListPtr = tsdPtr->nextPtr;
+ }
+ if (tsdPtr->nextPtr) {
+ tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
+ }
+ tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
+ tsdPtr->onList = 0;
+ if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
+ Tcl_Panic("Tcl_WaitForEvent: %s",
+ "unable to write to triggerPipe");
+ }
+ }
+#else /* !TCL_THREADS */
+ tsdPtr->readyMasks = tsdPtr->checkMasks;
+ numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable,
+ &tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception,
+ timeoutPtr);
+
+ /*
+ * Some systems don't clear the masks after an error, so we have to do it
+ * here.
+ */
+
+ if (numFound == -1) {
+ FD_ZERO(&tsdPtr->readyMasks.readable);
+ FD_ZERO(&tsdPtr->readyMasks.writable);
+ FD_ZERO(&tsdPtr->readyMasks.exception);
+ }
+#endif /* TCL_THREADS */
+
+ /*
+ * Queue all detected file events before returning.
+ */
+
+ for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
+ filePtr = filePtr->nextPtr) {
+ mask = 0;
+ if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.readable)) {
+ mask |= TCL_READABLE;
+ }
+ if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.writable)) {
+ mask |= TCL_WRITABLE;
+ }
+ if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.exception)) {
+ mask |= TCL_EXCEPTION;
+ }
+
+ if (!mask) {
+ continue;
+ }
+
+ /*
+ * Don't bother to queue an event if the mask was previously non-zero
+ * since an event must still be on the queue.
+ */
+
+ if (filePtr->readyMask == 0) {
+ FileHandlerEvent *fileEvPtr =
+ (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
+
+ fileEvPtr->header.proc = FileHandlerEventProc;
+ fileEvPtr->fd = filePtr->fd;
+ Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
+ }
+ filePtr->readyMask = mask;
+ }
+#if TCL_THREADS
+ pthread_mutex_unlock(&notifierMutex);
+#endif /* TCL_THREADS */
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ if (write(triggerPipe, "S", 1) != 1) {
+ asyncPending = 0;
+ return 0;
+ };
+ }
+ return 1;
+ }
+ return 0;
+ }
+
+ /*
+ * Re-send the signal to the notifier thread.
+ */
+
+ pthread_kill((pthread_t) notifierThread, sigNumber);
+#else
+ (void)sigNumber;
+ (void)flagPtr;
+ (void)value;
+#endif
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NotifierThreadProc --
+ *
+ * This routine is the initial (and only) function executed by the
+ * special notifier thread. Its job is to wait for file descriptors to
+ * become readable or writable or to have an exception condition and then
+ * to notify other threads who are interested in this information by
+ * signalling a condition variable. Other threads can signal this
+ * notifier thread of a change in their interests by writing a single
+ * byte to a special pipe that the notifier thread is monitoring.
+ *
+ * Result:
+ * None. Once started, this routine normally never exits and usually dies
+ * with the overall process, but it can be shut down if the Tcl library
+ * is finalized.
+ *
+ * Side effects:
+ * The trigger pipe used to signal the notifier thread is created when
+ * the notifier thread first starts.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#if TCL_THREADS
+static TCL_NORETURN void
+NotifierThreadProc(
+ TCL_UNUSED(ClientData))
+{
+ ThreadSpecificData *tsdPtr;
+ fd_set readableMask;
+ fd_set writableMask;
+ fd_set exceptionMask;
+ int i, fds[2], receivePipe, ret;
+ long found;
+ struct timeval poll = {0, 0}, *timePtr;
+ char buf[2];
+ int numFdBits = 0;
+
+ if (pipe(fds) != 0) {
+ Tcl_Panic("NotifierThreadProc: %s", "could not create trigger pipe");
+ }
+
+ /*
+ * Ticket [c6897e6e6a].
+ */
+
+ if (fds[0] >= FD_SETSIZE || fds[1] >= FD_SETSIZE) {
+ Tcl_Panic("NotifierThreadProc: %s", "too many open files");
+ }
+
+ receivePipe = fds[0];
+
+ if (TclUnixSetBlockingMode(receivePipe, TCL_MODE_NONBLOCKING) < 0) {
+ Tcl_Panic("NotifierThreadProc: %s",
+ "could not make receive pipe non blocking");
+ }
+ if (TclUnixSetBlockingMode(fds[1], TCL_MODE_NONBLOCKING) < 0) {
+ Tcl_Panic("NotifierThreadProc: %s",
+ "could not make trigger pipe non blocking");
+ }
+ if (fcntl(receivePipe, F_SETFD, FD_CLOEXEC) < 0) {
+ Tcl_Panic("NotifierThreadProc: %s",
+ "could not make receive pipe close-on-exec");
+ }
+ if (fcntl(fds[1], F_SETFD, FD_CLOEXEC) < 0) {
+ Tcl_Panic("NotifierThreadProc: %s",
+ "could not make trigger pipe close-on-exec");
+ }
+
+ /*
+ * Install the write end of the pipe into the global variable.
+ */
+
+ pthread_mutex_lock(&notifierMutex);
+ triggerPipe = fds[1];
+ otherPipe = fds[0];
+
+ /*
+ * Signal any threads that are waiting.
+ */
+
+ pthread_cond_broadcast(&notifierCV);
+ pthread_mutex_unlock(&notifierMutex);
+
+ /*
+ * Look for file events and report them to interested threads.
+ */
+
+ while (1) {
+ FD_ZERO(&readableMask);
+ FD_ZERO(&writableMask);
+ FD_ZERO(&exceptionMask);
+
+ /*
+ * Compute the logical OR of the masks from all the waiting
+ * notifiers.
+ */
+
+ pthread_mutex_lock(&notifierMutex);
+ timePtr = NULL;
+ for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
+ for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
+ if (FD_ISSET(i, &tsdPtr->checkMasks.readable)) {
+ FD_SET(i, &readableMask);
+ }
+ if (FD_ISSET(i, &tsdPtr->checkMasks.writable)) {
+ FD_SET(i, &writableMask);
+ }
+ if (FD_ISSET(i, &tsdPtr->checkMasks.exception)) {
+ FD_SET(i, &exceptionMask);
+ }
+ }
+ if (tsdPtr->numFdBits > numFdBits) {
+ numFdBits = tsdPtr->numFdBits;
+ }
+ if (tsdPtr->pollState & POLL_WANT) {
+ /*
+ * Here we make sure we go through select() with the same mask
+ * bits that were present when the thread tried to poll.
+ */
+
+ tsdPtr->pollState |= POLL_DONE;
+ timePtr = &poll;
+ }
+ }
+ pthread_mutex_unlock(&notifierMutex);
+
+ /*
+ * Set up the mask to include the receive pipe.
+ */
+
+ if (receivePipe >= numFdBits) {
+ numFdBits = receivePipe + 1;
+ }
+ FD_SET(receivePipe, &readableMask);
+
+ /*
+ * Signals are unblocked only during select().
+ */
+
+#ifdef HAVE_PSELECT
+ {
+ struct timespec tspec, *tspecPtr;
+
+ if (timePtr == NULL) {
+ tspecPtr = NULL;
+ } else {
+ tspecPtr = &tspec;
+ tspecPtr->tv_sec = timePtr->tv_sec;
+ tspecPtr->tv_nsec = timePtr->tv_usec * 1000;
+ }
+ ret = pselect(numFdBits, &readableMask, &writableMask,
+ &exceptionMask, tspecPtr, &notifierSigMask);
+ }
+#else
+ pthread_sigmask(SIG_SETMASK, &notifierSigMask, NULL);
+ ret = select(numFdBits, &readableMask, &writableMask, &exceptionMask,
+ timePtr);
+ pthread_sigmask(SIG_BLOCK, &allSigMask, NULL);
+#endif
+
+ 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 select() error.
+ */
+ continue;
+ }
+
+ /*
+ * Alert any threads that are waiting on a ready file descriptor.
+ */
+
+ pthread_mutex_lock(&notifierMutex);
+ for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
+ found = 0;
+
+ for (i = tsdPtr->numFdBits - 1; i >= 0; --i) {
+ if (FD_ISSET(i, &tsdPtr->checkMasks.readable)
+ && FD_ISSET(i, &readableMask)) {
+ FD_SET(i, &tsdPtr->readyMasks.readable);
+ found = 1;
+ }
+ if (FD_ISSET(i, &tsdPtr->checkMasks.writable)
+ && FD_ISSET(i, &writableMask)) {
+ FD_SET(i, &tsdPtr->readyMasks.writable);
+ found = 1;
+ }
+ if (FD_ISSET(i, &tsdPtr->checkMasks.exception)
+ && FD_ISSET(i, &exceptionMask)) {
+ FD_SET(i, &tsdPtr->readyMasks.exception);
+ found = 1;
+ }
+ }
+
+ if (found || (tsdPtr->pollState & POLL_DONE)) {
+ AlertSingleThread(tsdPtr);
+ }
+ }
+ pthread_mutex_unlock(&notifierMutex);
+
+ /*
+ * Consume the next byte from the notifier pipe if the pipe was
+ * readable. Note that there may be multiple bytes pending, but to
+ * avoid a race condition we only read one at a time.
+ */
+
+ do {
+ i = read(receivePipe, buf, 1);
+ if (i <= 0) {
+ break;
+ } else if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
+ /*
+ * Someone closed the write end of the pipe or sent us a Quit
+ * message [Bug: 4139] and then closed the write end of the
+ * pipe so we need to shut down the notifier thread.
+ */
+
+ break;
+ }
+ } while (1);
+
+ if (asyncPending) {
+ asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
+
+ if ((i == 0) || (buf[0] == 'q')) {
+ break;
+ }
+ }
+
+ /*
+ * Clean up the read end of the pipe and signal any threads waiting on
+ * termination of the notifier thread.
+ */
+
+ close(receivePipe);
+ pthread_mutex_lock(&notifierMutex);
+ triggerPipe = -1;
+ otherPipe = -1;
+ pthread_cond_broadcast(&notifierCV);
+ pthread_mutex_unlock(&notifierMutex);
+
+ TclpThreadExit(0);
+}
+#endif /* TCL_THREADS */
+
+#endif /* (!NOTIFIER_EPOLL && !NOTIFIER_KQUEUE) || !TCL_THREADS */
+#else
+TCL_MAC_EMPTY_FILE(unix_tclSelectNotfy_c)
+#endif /* !HAVE_COREFOUNDATION */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c
index 2f51226..a7a6eb1 100644
--- a/unix/tclUnixChan.c
+++ b/unix/tclUnixChan.c
@@ -4,8 +4,8 @@
* Common channel driver for Unix channels based on files, command pipes
* and TCP sockets.
*
- * 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.
@@ -49,6 +49,16 @@
#endif /* HAVE_TERMIOS_H */
/*
+ * The bits supported for describing the closeMode field of TtyState.
+ */
+
+enum CloseModeBits {
+ CLOSE_DEFAULT,
+ CLOSE_DRAIN,
+ CLOSE_DISCARD
+};
+
+/*
* Helper macros to make parts of this file clearer. The macros do exactly
* what they say on the tin. :-) They also only ever refer to their arguments
* once, and so can be used without regard to side effects.
@@ -58,10 +68,11 @@
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
/*
- * This structure describes per-instance state of a file based channel.
+ * These structures describe per-instance state of file-based and serial-based
+ * channels.
*/
-typedef struct FileState {
+typedef struct {
Tcl_Channel channel; /* Channel associated with this file. */
int fd; /* File handle. */
int validMask; /* OR'ed combination of TCL_READABLE,
@@ -69,6 +80,18 @@ typedef struct FileState {
* which operations are valid on the file. */
} FileState;
+typedef struct {
+ FileState fileState;
+#ifdef SUPPORTS_TTY
+ int closeMode; /* One of CLOSE_DEFAULT, CLOSE_DRAIN or
+ * CLOSE_DISCARD. */
+ int doReset; /* Whether we should do a terminal reset on
+ * close. */
+ struct termios initState; /* The state of the terminal when it was
+ * opened. */
+#endif /* SUPPORTS_TTY */
+} TtyState;
+
#ifdef SUPPORTS_TTY
/*
@@ -76,14 +99,14 @@ typedef struct FileState {
* a platform-independent manner.
*/
-typedef struct TtyAttrs {
+typedef struct {
int baud;
int parity;
int data;
int stop;
} TtyAttrs;
-#endif /* !SUPPORTS_TTY */
+#endif /* SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
if (interp) { \
@@ -96,27 +119,29 @@ typedef struct TtyAttrs {
* Static routines for this file:
*/
-static int FileBlockModeProc(ClientData instanceData, int mode);
-static int FileCloseProc(ClientData instanceData,
- Tcl_Interp *interp);
-static int FileClose2Proc(ClientData instanceData,
+static int FileBlockModeProc(void *instanceData, int mode);
+static int FileCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
-static int FileGetHandleProc(ClientData instanceData,
- int direction, ClientData *handlePtr);
-static int FileInputProc(ClientData instanceData, char *buf,
+static int FileGetHandleProc(void *instanceData,
+ int direction, void **handlePtr);
+static int FileInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
-static int FileOutputProc(ClientData instanceData,
+static int FileOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
-static int FileSeekProc(ClientData instanceData, long offset,
+#ifndef TCL_NO_DEPRECATED
+static int FileSeekProc(void *instanceData, long offset,
int mode, int *errorCode);
-static int FileTruncateProc(ClientData instanceData,
- Tcl_WideInt length);
-static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCode);
-static void FileWatchProc(ClientData instanceData, int mask);
+#endif
+static int FileTruncateProc(void *instanceData,
+ long long length);
+static long long FileWideSeekProc(void *instanceData,
+ long long offset, int mode, int *errorCode);
+static void FileWatchProc(void *instanceData, int mask);
#ifdef SUPPORTS_TTY
+static int TtyCloseProc(void *instanceData,
+ Tcl_Interp *interp, int flags);
static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr);
-static int TtyGetOptionProc(ClientData instanceData,
+static int TtyGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int TtyGetBaud(speed_t speed);
@@ -126,7 +151,7 @@ static void TtyModemStatusStr(int status, Tcl_DString *dsPtr);
static int TtyParseMode(Tcl_Interp *interp, const char *mode,
TtyAttrs *ttyPtr);
static void TtySetAttributes(int fd, TtyAttrs *ttyPtr);
-static int TtySetOptionProc(ClientData instanceData,
+static int TtySetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
#endif /* SUPPORTS_TTY */
@@ -138,15 +163,19 @@ static int TtySetOptionProc(ClientData instanceData,
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- FileCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
+#ifndef TCL_NO_DEPRECATED
FileSeekProc, /* Seek proc. */
+#else
+ NULL,
+#endif
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
- FileClose2Proc, /* close2proc. */
+ FileCloseProc, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
@@ -164,7 +193,7 @@ static const Tcl_ChannelType fileChannelType = {
static const Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- FileCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
NULL, /* Seek proc. */
@@ -172,7 +201,7 @@ static const Tcl_ChannelType ttyChannelType = {
TtyGetOptionProc, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
- FileClose2Proc, /* close2proc. */
+ TtyCloseProc, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
@@ -201,11 +230,11 @@ static const Tcl_ChannelType ttyChannelType = {
static int
FileBlockModeProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
int mode) /* The mode to set. Can be TCL_MODE_BLOCKING
* or TCL_MODE_NONBLOCKING. */
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) {
return errno;
@@ -234,13 +263,13 @@ FileBlockModeProc(
static int
FileInputProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
char *buf, /* Where to store data read. */
int toRead, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
* input device? */
@@ -284,12 +313,12 @@ FileInputProc(
static int
FileOutputProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
int written;
*errorCodePtr = 0;
@@ -304,7 +333,7 @@ FileOutputProc(
return 0;
}
written = write(fsPtr->fd, buf, (size_t) toWrite);
- if (written > -1) {
+ if (written >= 0) {
return written;
}
*errorCodePtr = errno;
@@ -314,10 +343,11 @@ FileOutputProc(
/*
*----------------------------------------------------------------------
*
- * FileCloseProc --
+ * FileCloseProc, TtyCloseProc --
*
- * This function is called from the generic IO level to perform
- * channel-type-specific cleanup when a file based channel is closed.
+ * These functions are called from the generic IO level to perform
+ * channel-type-specific cleanup when a file- or tty-based channel is
+ * closed.
*
* Results:
* 0 if successful, errno if failed.
@@ -330,12 +360,17 @@ FileOutputProc(
static int
FileCloseProc(
- ClientData instanceData, /* File state. */
- Tcl_Interp *interp) /* For error reporting - unused. */
+ void *instanceData, /* File state. */
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
int errorCode = 0;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
Tcl_DeleteFileHandler(fsPtr->fd);
/*
@@ -351,17 +386,50 @@ FileCloseProc(
ckfree(fsPtr);
return errorCode;
}
+
+#ifdef SUPPORTS_TTY
static int
-FileClose2Proc(
- ClientData instanceData, /* File state. */
- Tcl_Interp *interp, /* For error reporting - unused. */
+TtyCloseProc(
+ void *instanceData,
+ Tcl_Interp *interp,
int flags)
{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return FileCloseProc(instanceData, interp);
+ TtyState *ttyPtr = (TtyState*)instanceData;
+
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+ /*
+ * If we've been asked by the user to drain or flush, do so now.
+ */
+
+ switch (ttyPtr->closeMode) {
+ case CLOSE_DRAIN:
+ tcdrain(ttyPtr->fileState.fd);
+ break;
+ case CLOSE_DISCARD:
+ tcflush(ttyPtr->fileState.fd, TCIOFLUSH);
+ break;
+ default:
+ /* Do nothing */
+ break;
+ }
+
+ /*
+ * If we've had our state changed from the default, reset now.
+ */
+
+ if (ttyPtr->doReset) {
+ tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
- return EINVAL;
+
+ /*
+ * Delegate to close for files.
+ */
+
+ return FileCloseProc(instanceData, interp, flags);
}
+#endif /* SUPPORTS_TTY */
/*
*----------------------------------------------------------------------
@@ -381,24 +449,24 @@ FileClose2Proc(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_SET or SEEK_END. */
int *errorCodePtr) /* To store error code. */
{
- FileState *fsPtr = instanceData;
- Tcl_WideInt oldLoc, newLoc;
+ FileState *fsPtr = (FileState *)instanceData;
+ long long oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
- if (oldLoc == Tcl_LongAsWide(-1)) {
+ if (oldLoc == -1) {
/*
* Bad things are happening. Error out...
*/
@@ -413,15 +481,16 @@ FileSeekProc(
* Check for expressability in our return type, and roll-back otherwise.
*/
- if (newLoc > Tcl_LongAsWide(INT_MAX)) {
+ if (newLoc > INT_MAX) {
*errorCodePtr = EOVERFLOW;
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
- *errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
+ *errorCodePtr = (newLoc == -1) ? errno : 0;
}
- return (int) Tcl_WideAsLong(newLoc);
+ return (int) newLoc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -443,16 +512,16 @@ FileSeekProc(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
FileWideSeekProc(
- ClientData instanceData, /* File state. */
- Tcl_WideInt offset, /* Offset to seek to. */
+ void *instanceData, /* File state. */
+ long long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_CUR or SEEK_END. */
int *errorCodePtr) /* To store error code. */
{
- FileState *fsPtr = instanceData;
- Tcl_WideInt newLoc;
+ FileState *fsPtr = (FileState *)instanceData;
+ long long newLoc;
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
@@ -479,12 +548,12 @@ FileWideSeekProc(
static void
FileWatchProc(
- ClientData instanceData, /* The file state. */
+ void *instanceData, /* The file state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
/*
* Make sure we only register for events that are valid on this file. Note
@@ -521,11 +590,11 @@ FileWatchProc(
static int
FileGetHandleProc(
- ClientData instanceData, /* The file state. */
+ void *instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr) /* Where to store the handle. */
+ void **handlePtr) /* Where to store the handle. */
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
if (direction & fsPtr->validMask) {
*handlePtr = INT2PTR(fsPtr->fd);
@@ -588,12 +657,12 @@ TtyModemStatusStr(
static int
TtySetOptionProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
- FileState *fsPtr = instanceData;
+ TtyState *fsPtr = (TtyState *)instanceData;
unsigned int len, vlen;
TtyAttrs tty;
int argc;
@@ -616,11 +685,10 @@ TtySetOptionProc(
* system calls results should be checked there. - dl
*/
- TtySetAttributes(fsPtr->fd, &tty);
+ TtySetAttributes(fsPtr->fileState.fd, &tty);
return TCL_OK;
}
-
/*
* Option -handshake none|xonxoff|rtscts|dtrdsr
*/
@@ -630,7 +698,7 @@ TtySetOptionProc(
* Reset all handshake options. DTR and RTS are ON by default.
*/
- tcgetattr(fsPtr->fd, &iostate);
+ tcgetattr(fsPtr->fileState.fd, &iostate);
CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY);
#ifdef CRTSCTS
CLEAR_BITS(iostate.c_cflag, CRTSCTS);
@@ -661,7 +729,7 @@ TtySetOptionProc(
}
return TCL_ERROR;
}
- tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
+ tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
@@ -670,34 +738,42 @@ TtySetOptionProc(
*/
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
- Tcl_DString ds;
-
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
} else if (argc != 2) {
+ badXchar:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
- " two elements", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
- "VALUE", NULL);
+ " two elements with each a single 8-bit character", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
- tcgetattr(fsPtr->fd, &iostate);
+ tcgetattr(fsPtr->fileState.fd, &iostate);
- Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds);
- iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds);
- TclDStringClear(&ds);
+ iostate.c_cc[VSTART] = argv[0][0];
+ iostate.c_cc[VSTOP] = argv[1][0];
+ if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
+ Tcl_UniChar character = 0;
+ int charLen;
- Tcl_UtfToExternalDString(NULL, argv[1], -1, &ds);
- iostate.c_cc[VSTOP] = *(const cc_t *) Tcl_DStringValue(&ds);
- Tcl_DStringFree(&ds);
+ charLen = Tcl_UtfToUniChar(argv[0], &character);
+ if ((character > 0xFF) || argv[0][charLen]) {
+ goto badXchar;
+ }
+ iostate.c_cc[VSTART] = character;
+ charLen = Tcl_UtfToUniChar(argv[1], &character);
+ if ((character > 0xFF) || argv[1][charLen]) {
+ goto badXchar;
+ }
+ iostate.c_cc[VSTOP] = character;
+ }
ckfree(argv);
- tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
+ tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
@@ -708,19 +784,20 @@ TtySetOptionProc(
if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
int msec;
- tcgetattr(fsPtr->fd, &iostate);
+ tcgetattr(fsPtr->fileState.fd, &iostate);
if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
return TCL_ERROR;
}
iostate.c_cc[VMIN] = 0;
iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100;
- tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
+ tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
+
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
#if defined(TIOCMGET) && defined(TIOCMSET)
int i, control, flag;
@@ -740,7 +817,7 @@ TtySetOptionProc(
return TCL_ERROR;
}
- ioctl(fsPtr->fd, TIOCMGET, &control);
+ ioctl(fsPtr->fileState.fd, TIOCMGET, &control);
for (i = 0; i < argc-1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
ckfree(argv);
@@ -761,9 +838,9 @@ TtySetOptionProc(
} else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
#if defined(TIOCSBRK) && defined(TIOCCBRK)
if (flag) {
- ioctl(fsPtr->fd, TIOCSBRK, NULL);
+ ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL);
} else {
- ioctl(fsPtr->fd, TIOCCBRK, NULL);
+ ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL);
}
#else /* TIOCSBRK & TIOCCBRK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
@@ -783,7 +860,7 @@ TtySetOptionProc(
}
} /* -ttycontrol options loop */
- ioctl(fsPtr->fd, TIOCMSET, &control);
+ ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
ckfree(argv);
return TCL_OK;
#else /* TIOCMGET&TIOCMSET */
@@ -791,8 +868,112 @@ TtySetOptionProc(
#endif /* TIOCMGET&TIOCMSET */
}
+ /*
+ * Option -closemode drain|discard
+ */
+
+ if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) {
+ if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) {
+ fsPtr->closeMode = CLOSE_DEFAULT;
+ } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) {
+ fsPtr->closeMode = CLOSE_DRAIN;
+ } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) {
+ fsPtr->closeMode = CLOSE_DISCARD;
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad mode \"%s\" for -closemode: must be"
+ " default, discard, or drain", value));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+ "VALUE", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Option -inputmode normal|password|raw
+ */
+
+ if ((len > 2) && (strncmp(optionName, "-inputmode", len) == 0)) {
+ if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read serial terminal control state: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
+ SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON);
+ SET_BITS(iostate.c_oflag, OPOST);
+ SET_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG);
+ } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
+ SET_BITS(iostate.c_iflag, BRKINT | IGNPAR | ISTRIP | ICRNL | IXON);
+ SET_BITS(iostate.c_oflag, OPOST);
+ CLEAR_BITS(iostate.c_lflag, ECHO);
+ /*
+ * Note: password input turns out to be best if you echo the
+ * newline that the user types. Theoretically we could get users
+ * to do the processing of this in their scripts, but it always
+ * feels highly unnatural to do so in practice.
+ */
+ SET_BITS(iostate.c_lflag, ECHONL | ICANON | ISIG);
+ } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
+#ifdef HAVE_CFMAKERAW
+ cfmakeraw(&iostate);
+#else /* !HAVE_CFMAKERAW */
+ CLEAR_BITS(iostate.c_iflag, IGNBRK | BRKINT | PARMRK | ISTRIP
+ | INLCR | IGNCR | ICRNL | IXON);
+ CLEAR_BITS(iostate.c_oflag, OPOST);
+ CLEAR_BITS(iostate.c_lflag, ECHO | ECHONL | ICANON | ISIG | IEXTEN);
+ CLEAR_BITS(iostate.c_cflag, CSIZE | PARENB);
+ SET_BITS(iostate.c_cflag, CS8);
+#endif /* HAVE_CFMAKERAW */
+ } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
+ /*
+ * Reset to the initial state, whatever that is.
+ */
+
+ memcpy(&iostate, &fsPtr->initState, sizeof(struct termios));
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad mode \"%s\" for -inputmode: must be"
+ " normal, password, raw, or reset", value));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+ "VALUE", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate) < 0) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't update serial terminal control state: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * If we've changed the state from default, schedule a reset later.
+ * Note that this specifically does not detect changes made by calling
+ * an external stty program; that is deliberate, as it maintains
+ * compatibility with existing code!
+ *
+ * This mechanism in Tcl is not intended to be a full replacement for
+ * what stty does; it just handles a few common cases and tries not to
+ * leave things in a broken state.
+ */
+
+ fsPtr->doReset = (memcmp(&iostate, &fsPtr->initState,
+ sizeof(struct termios)) != 0);
+ return TCL_OK;
+ }
+
return Tcl_BadChannelOption(interp, optionName,
- "mode handshake timeout ttycontrol xchar");
+ "closemode inputmode mode handshake timeout ttycontrol xchar");
}
/*
@@ -815,21 +996,79 @@ TtySetOptionProc(
static int
TtyGetOptionProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
- FileState *fsPtr = instanceData;
+ TtyState *fsPtr = (TtyState *)instanceData;
unsigned int len;
char buf[3*TCL_INTEGER_SPACE + 16];
int valid = 0; /* Flag if valid option parsed. */
+ struct termios iostate;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
+
+ /*
+ * Get option -closemode
+ */
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-closemode");
+ }
+ if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) {
+ switch (fsPtr->closeMode) {
+ case CLOSE_DRAIN:
+ Tcl_DStringAppendElement(dsPtr, "drain");
+ break;
+ case CLOSE_DISCARD:
+ Tcl_DStringAppendElement(dsPtr, "discard");
+ break;
+ default:
+ Tcl_DStringAppendElement(dsPtr, "default");
+ break;
+ }
+ }
+
+ /*
+ * Get option -inputmode
+ *
+ * This is a great simplification of the underlying reality, but actually
+ * represents what almost all scripts really want to know.
+ */
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-inputmode");
+ }
+ if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
+ valid = 1;
+ if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read serial terminal control state: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ if (iostate.c_lflag & ICANON) {
+ if (iostate.c_lflag & ECHO) {
+ Tcl_DStringAppendElement(dsPtr, "normal");
+ } else {
+ Tcl_DStringAppendElement(dsPtr, "password");
+ }
+ } else {
+ Tcl_DStringAppendElement(dsPtr, "raw");
+ }
+ }
+
+ /*
+ * Get option -mode
+ */
+
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
}
@@ -837,7 +1076,7 @@ TtyGetOptionProc(
TtyAttrs tty;
valid = 1;
- TtyGetAttributes(fsPtr->fd, &tty);
+ TtyGetAttributes(fsPtr->fileState.fd, &tty);
snprintf(buf, sizeof(buf), "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
Tcl_DStringAppendElement(dsPtr, buf);
}
@@ -851,11 +1090,10 @@ TtyGetOptionProc(
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
- struct termios iostate;
Tcl_DString ds;
valid = 1;
- tcgetattr(fsPtr->fd, &iostate);
+ tcgetattr(fsPtr->fileState.fd, &iostate);
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds);
@@ -880,10 +1118,10 @@ TtyGetOptionProc(
int inQueue=0, outQueue=0, inBuffered, outBuffered;
valid = 1;
- GETREADQUEUE(fsPtr->fd, inQueue);
- GETWRITEQUEUE(fsPtr->fd, outQueue);
- inBuffered = Tcl_InputBuffered(fsPtr->channel);
- outBuffered = Tcl_OutputBuffered(fsPtr->channel);
+ GETREADQUEUE(fsPtr->fileState.fd, inQueue);
+ GETWRITEQUEUE(fsPtr->fileState.fd, outQueue);
+ inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel);
+ outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel);
snprintf(buf, sizeof(buf), "%d", inBuffered+inQueue);
Tcl_DStringAppendElement(dsPtr, buf);
@@ -897,24 +1135,49 @@ TtyGetOptionProc(
* Option is readonly and returned by [fconfigure chan -ttystatus] but not
* returned by unnamed [fconfigure chan].
*/
+
if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
int status;
valid = 1;
- ioctl(fsPtr->fd, TIOCMGET, &status);
+ ioctl(fsPtr->fileState.fd, TIOCMGET, &status);
TtyModemStatusStr(status, dsPtr);
}
#endif /* TIOCMGET */
+#if defined(TIOCGWINSZ)
+ /*
+ * Get option -winsize
+ * Option is readonly and returned by [fconfigure chan -winsize] but not
+ * returned by [fconfigure chan] without explicit option name.
+ */
+
+ if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
+ struct winsize ws;
+
+ valid = 1;
+ if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read terminal size: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ snprintf(buf, sizeof(buf), "%d", ws.ws_col);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ snprintf(buf, sizeof(buf), "%d", ws.ws_row);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+#endif /* TIOCGWINSZ */
+
if (valid) {
return TCL_OK;
}
- return Tcl_BadChannelOption(interp, optionName, "mode"
- " queue ttystatus xchar"
- );
+ return Tcl_BadChannelOption(interp, optionName,
+ "closemode inputmode mode queue ttystatus winsize xchar");
}
-
static const struct {int baud; speed_t speed;} speeds[] = {
#ifdef B0
{0, B0},
@@ -1038,7 +1301,7 @@ static const struct {int baud; speed_t speed;} speeds[] = {
#endif
{-1, 0}
};
-
+
/*
*---------------------------------------------------------------------------
*
@@ -1330,7 +1593,8 @@ TtyParseMode(
static void
TtyInit(
- int fd) /* Open file descriptor for serial port to be initialized. */
+ int fd) /* Open file descriptor for serial port to be
+ * initialized. */
{
struct termios iostate;
tcgetattr(fd, &iostate);
@@ -1340,8 +1604,7 @@ TtyInit(
|| iostate.c_lflag != 0
|| iostate.c_cflag & CREAD
|| iostate.c_cc[VMIN] != 1
- || iostate.c_cc[VTIME] != 0)
- {
+ || iostate.c_cc[VTIME] != 0) {
iostate.c_iflag = IGNBRK;
iostate.c_oflag = 0;
iostate.c_lflag = 0;
@@ -1383,7 +1646,7 @@ TclpOpenFileChannel(
* what modes to create it? */
{
int fd, channelPermissions;
- FileState *fsPtr;
+ TtyState *fsPtr;
const char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
const Tcl_ChannelType *channelTypePtr;
@@ -1407,7 +1670,7 @@ TclpOpenFileChannel(
return NULL;
}
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const char *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
@@ -1439,8 +1702,6 @@ TclpOpenFileChannel(
fcntl(fd, F_SETFD, FD_CLOEXEC);
- snprintf(channelName, sizeof(channelName), "file%d", fd);
-
#ifdef SUPPORTS_TTY
if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
/*
@@ -1460,18 +1721,27 @@ TclpOpenFileChannel(
translation = "auto crlf";
channelTypePtr = &ttyChannelType;
TtyInit(fd);
+ snprintf(channelName, sizeof(channelName), "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
+ snprintf(channelName, sizeof(channelName), "file%d", fd);
}
- fsPtr = ckalloc(sizeof(FileState));
- fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
- fsPtr->fd = fd;
+ fsPtr = (TtyState *)ckalloc(sizeof(TtyState));
+ fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION;
+ fsPtr->fileState.fd = fd;
+#ifdef SUPPORTS_TTY
+ if (channelTypePtr == &ttyChannelType) {
+ fsPtr->closeMode = CLOSE_DEFAULT;
+ fsPtr->doReset = 0;
+ tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
+ }
+#endif /* SUPPORTS_TTY */
- fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
+ fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, channelPermissions);
if (translation != NULL) {
@@ -1483,14 +1753,14 @@ TclpOpenFileChannel(
* reports that the serial port isn't working.
*/
- if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation",
- translation) != TCL_OK) {
- Tcl_Close(NULL, fsPtr->channel);
+ if (Tcl_SetChannelOption(interp, fsPtr->fileState.channel,
+ "-translation", translation) != TCL_OK) {
+ Tcl_Close(NULL, fsPtr->fileState.channel);
return NULL;
}
}
- return fsPtr->channel;
+ return fsPtr->fileState.channel;
}
/*
@@ -1511,11 +1781,11 @@ TclpOpenFileChannel(
Tcl_Channel
Tcl_MakeFileChannel(
- ClientData handle, /* OS level handle. */
+ void *handle, /* OS level handle. */
int mode) /* OR'ed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
- FileState *fsPtr;
+ TtyState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = PTR2INT(handle);
const Tcl_ChannelType *channelTypePtr;
@@ -1534,22 +1804,30 @@ Tcl_MakeFileChannel(
snprintf(channelName, sizeof(channelName), "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
- if ((getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0)
- && (sockaddrLen > 0)
- && (sockaddr.sa_family == AF_INET || sockaddr.sa_family == AF_INET6)) {
- return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
+ if ((getsockname(fd, (struct sockaddr *) &sockaddr, &sockaddrLen) == 0)
+ && (sockaddrLen > 0)
+ && (sockaddr.sa_family == AF_INET
+ || sockaddr.sa_family == AF_INET6)) {
+ return (Tcl_Channel)TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
} else {
channelTypePtr = &fileChannelType;
snprintf(channelName, sizeof(channelName), "file%d", fd);
}
- fsPtr = ckalloc(sizeof(FileState));
- fsPtr->fd = fd;
- fsPtr->validMask = mode | TCL_EXCEPTION;
- fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
+ fsPtr = (TtyState *)ckalloc(sizeof(TtyState));
+ fsPtr->fileState.fd = fd;
+ fsPtr->fileState.validMask = mode | TCL_EXCEPTION;
+ fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, mode);
+#ifdef SUPPORTS_TTY
+ if (channelTypePtr == &ttyChannelType) {
+ fsPtr->closeMode = CLOSE_DEFAULT;
+ fsPtr->doReset = 0;
+ tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
+ }
+#endif /* SUPPORTS_TTY */
- return fsPtr->channel;
+ return fsPtr->fileState.channel;
}
/*
@@ -1582,12 +1860,11 @@ TclpGetDefaultStdChannel(
* Some #def's to make the code a little clearer!
*/
-#define ZERO_OFFSET ((Tcl_SeekOffset) 0)
#define ERROR_OFFSET ((Tcl_SeekOffset) -1)
switch (type) {
case TCL_STDIN:
- if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
+ if ((TclOSseek(0, 0, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
@@ -1596,7 +1873,7 @@ TclpGetDefaultStdChannel(
bufMode = "line";
break;
case TCL_STDOUT:
- if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
+ if ((TclOSseek(1, 0, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
@@ -1605,7 +1882,7 @@ TclpGetDefaultStdChannel(
bufMode = "line";
break;
case TCL_STDERR:
- if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
+ if ((TclOSseek(2, 0, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
@@ -1618,7 +1895,6 @@ TclpGetDefaultStdChannel(
break;
}
-#undef ZERO_OFFSET
#undef ERROR_OFFSET
channel = Tcl_MakeFileChannel(INT2PTR(fd), mode);
@@ -1667,17 +1943,16 @@ Tcl_GetOpenFile(
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
- int checkUsage, /* 1 means verify that the file was opened in
- * a mode that allows the access specified by
- * "forWriting". Ignored, we always check that
+ TCL_UNUSED(int), /* Obsolete argument.
+ * Ignored, we always check that
* the channel is open for the requested
* mode. */
- ClientData *filePtr) /* Store pointer to FILE structure here. */
+ void **filePtr) /* Store pointer to FILE structure here. */
{
Tcl_Channel chan;
int chanMode, fd;
const Tcl_ChannelType *chanTypePtr;
- ClientData data;
+ void *data;
FILE *f;
chan = Tcl_GetChannel(interp, chanID, &chanMode);
@@ -1741,166 +2016,6 @@ Tcl_GetOpenFile(
return TCL_ERROR;
}
-#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
- * in tclMacOSXNotify.c */
-/*
- *----------------------------------------------------------------------
- *
- * TclUnixWaitForFile --
- *
- * This function waits synchronously for a file to become readable or
- * writable, with an optional timeout.
- *
- * Results:
- * The return value is an OR'ed combination of TCL_READABLE,
- * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are
- * present on file at the time of the return. This function will not
- * return until either "timeout" milliseconds have elapsed or at least
- * one of the conditions given by mask has occurred for file (a return
- * value of 0 means that a timeout occurred). No normal events will be
- * serviced during the execution of this function.
- *
- * Side effects:
- * Time passes.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclUnixWaitForFile(
- int fd, /* Handle for file on which to wait. */
- int mask, /* What to wait for: OR'ed combination of
- * TCL_READABLE, TCL_WRITABLE, and
- * TCL_EXCEPTION. */
- int timeout) /* Maximum amount of time to wait for one of
- * the conditions in mask to occur, in
- * milliseconds. A value of 0 means don't wait
- * at all, and a value of -1 means wait
- * forever. */
-{
- Tcl_Time abortTime = {0, 0}, now; /* silence gcc 4 warning */
- struct timeval blockTime, *timeoutPtr;
- int numFound, result = 0;
- fd_set readableMask;
- fd_set writableMask;
- fd_set exceptionMask;
-
-#ifndef _DARWIN_C_SOURCE
- /*
- * Sanity check fd.
- */
-
- if (fd >= FD_SETSIZE) {
- Tcl_Panic("TclUnixWaitForFile can't handle file id %d", fd);
- /* must never get here, or select masks overrun will occur below */
- }
-#endif
-
- /*
- * If there is a non-zero finite timeout, compute the time when we give
- * up.
- */
-
- if (timeout > 0) {
- Tcl_GetTime(&now);
- abortTime.sec = now.sec + timeout/1000;
- abortTime.usec = now.usec + (timeout%1000)*1000;
- if (abortTime.usec >= 1000000) {
- abortTime.usec -= 1000000;
- abortTime.sec += 1;
- }
- timeoutPtr = &blockTime;
- } else if (timeout == 0) {
- timeoutPtr = &blockTime;
- blockTime.tv_sec = 0;
- blockTime.tv_usec = 0;
- } else {
- timeoutPtr = NULL;
- }
-
- /*
- * Initialize the select masks.
- */
-
- FD_ZERO(&readableMask);
- FD_ZERO(&writableMask);
- FD_ZERO(&exceptionMask);
-
- /*
- * Loop in a mini-event loop of our own, waiting for either the file to
- * become ready or a timeout to occur.
- */
-
- while (1) {
- if (timeout > 0) {
- blockTime.tv_sec = abortTime.sec - now.sec;
- blockTime.tv_usec = abortTime.usec - now.usec;
- if (blockTime.tv_usec < 0) {
- blockTime.tv_sec -= 1;
- blockTime.tv_usec += 1000000;
- }
- if (blockTime.tv_sec < 0) {
- blockTime.tv_sec = 0;
- blockTime.tv_usec = 0;
- }
- }
-
- /*
- * Setup the select masks for the fd.
- */
-
- if (mask & TCL_READABLE) {
- FD_SET(fd, &readableMask);
- }
- if (mask & TCL_WRITABLE) {
- FD_SET(fd, &writableMask);
- }
- if (mask & TCL_EXCEPTION) {
- FD_SET(fd, &exceptionMask);
- }
-
- /*
- * Wait for the event or a timeout.
- */
-
- numFound = select(fd + 1, &readableMask, &writableMask,
- &exceptionMask, timeoutPtr);
- if (numFound == 1) {
- if (FD_ISSET(fd, &readableMask)) {
- SET_BITS(result, TCL_READABLE);
- }
- if (FD_ISSET(fd, &writableMask)) {
- SET_BITS(result, TCL_WRITABLE);
- }
- if (FD_ISSET(fd, &exceptionMask)) {
- SET_BITS(result, TCL_EXCEPTION);
- }
- result &= mask;
- if (result) {
- break;
- }
- }
- if (timeout == 0) {
- break;
- }
- if (timeout < 0) {
- continue;
- }
-
- /*
- * The select returned early, so we need to recompute the timeout.
- */
-
- Tcl_GetTime(&now);
- if ((abortTime.sec < now.sec)
- || (abortTime.sec==now.sec && abortTime.usec<=now.usec)) {
- break;
- }
- }
- return result;
-}
-#endif /* HAVE_COREFOUNDATION */
-
/*
*----------------------------------------------------------------------
*
@@ -1922,10 +2037,10 @@ TclUnixWaitForFile(
static int
FileTruncateProc(
- ClientData instanceData,
- Tcl_WideInt length)
+ void *instanceData,
+ long long length)
{
- FileState *fsPtr = instanceData;
+ FileState *fsPtr = (FileState *)instanceData;
int result;
#ifdef HAVE_TYPE_OFF64_T
diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c
index 853e93a..3a7778e 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -47,7 +47,7 @@
* library calls.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
typedef struct {
struct passwd pwd;
@@ -182,7 +182,7 @@ struct passwd *
TclpGetPwNam(
const char *name)
{
-#if !defined(TCL_THREADS)
+#if !TCL_THREADS
return getpwnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -262,7 +262,7 @@ struct passwd *
TclpGetPwUid(
uid_t uid)
{
-#if !defined(TCL_THREADS)
+#if !TCL_THREADS
return getpwuid(uid);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -336,10 +336,9 @@ TclpGetPwUid(
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
- ClientData dummy)
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)dummy;
ckfree(tsdPtr->pbuf);
}
@@ -366,7 +365,7 @@ struct group *
TclpGetGrNam(
const char *name)
{
-#if !defined(TCL_THREADS)
+#if !TCL_THREADS
return getgrnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -446,7 +445,7 @@ struct group *
TclpGetGrGid(
gid_t gid)
{
-#if !defined(TCL_THREADS)
+#if !TCL_THREADS
return getgrgid(gid);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -520,10 +519,9 @@ TclpGetGrGid(
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
- ClientData dummy)
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)dummy;
ckfree(tsdPtr->gbuf);
}
@@ -550,7 +548,7 @@ struct hostent *
TclpGetHostByName(
const char *name)
{
-#if !defined(TCL_THREADS) || defined(HAVE_MTSAFE_GETHOSTBYNAME)
+#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYNAME)
return gethostbyname(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -620,7 +618,7 @@ TclpGetHostByAddr(
int length,
int type)
{
-#if !defined(TCL_THREADS) || defined(HAVE_MTSAFE_GETHOSTBYADDR)
+#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYADDR)
return gethostbyaddr(addr, length, type);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -990,13 +988,12 @@ CopyString(
int
TclWinCPUID(
- unsigned int index, /* Which CPUID value to retrieve. */
- unsigned int *regsPtr) /* Registers after the CPUID. */
+ int index, /* Which CPUID value to retrieve. */
+ int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
/* See: <http://en.wikipedia.org/wiki/CPUID> */
-#if defined(HAVE_CPUID)
#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
__asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */
"cpuid \n\t"
@@ -1011,7 +1008,9 @@ TclWinCPUID(
: "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
: "a"(index));
status = TCL_OK;
-#endif
+#else
+ (void)index;
+ (void)regsPtr;
#endif
return status;
}
diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c
index 40aac6f..0047dd9 100644
--- a/unix/tclUnixEvent.c
+++ b/unix/tclUnixEvent.c
@@ -3,7 +3,7 @@
*
* This file implements Unix specific event related routines.
*
- * 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.
@@ -64,7 +64,7 @@ Tcl_Sleep(
}
if ((vdelay.sec != 0) || (vdelay.usec != 0)) {
- tclScaleTimeProcPtr(&vdelay, tclTimeClientData);
+ TclScaleTime(&vdelay);
}
delay.tv_sec = vdelay.sec;
@@ -85,6 +85,8 @@ Tcl_Sleep(
}
}
+#else
+TCL_MAC_EMPTY_FILE(unix_tclUnixEvent_c)
#endif /* HAVE_COREFOUNDATION */
/*
* Local Variables:
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index 26429df..f8eaeb5 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -5,7 +5,7 @@
* subcommands of the "file" command. All filename arguments should
* already be translated to native format.
*
- * 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.
@@ -13,7 +13,7 @@
* Portions of this code were derived from NetBSD source code which has the
* following copyright notice:
*
- * Copyright (c) 1988, 1993, 1994
+ * Copyright © 1988, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -113,16 +113,8 @@ typedef int (TraversalProc)(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
* elsewhere in Tcl's core.
*/
-#ifdef DJGPP
-
-/*
- * See contrib/djgpp/tclDjgppFCmd.c for definition.
- */
-
-extern TclFileAttrProcs tclpFileAttrProcs[];
-extern const char *const tclpFileAttrStrings[];
+#ifndef DJGPP
-#else /* !DJGPP */
enum {
#if defined(__CYGWIN__)
UNIX_ARCHIVE_ATTRIBUTE,
@@ -142,10 +134,9 @@ enum {
MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,
MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
- UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */
+ UNIX_INVALID_ATTRIBUTE
};
-MODULE_SCOPE const char *const tclpFileAttrStrings[];
const char *const tclpFileAttrStrings[] = {
#if defined(__CYGWIN__)
"-archive",
@@ -167,7 +158,6 @@ const char *const tclpFileAttrStrings[] = {
NULL
};
-MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
const TclFileAttrProcs tclpFileAttrProcs[] = {
#if defined(__CYGWIN__)
{GetUnixFileAttributes, SetUnixFileAttributes},
@@ -256,7 +246,7 @@ Realpath(
#endif /* PURIFY */
#ifndef NO_REALPATH
-#if defined(__APPLE__) && defined(TCL_THREADS) && \
+#if defined(__APPLE__) && TCL_THREADS && \
defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
MAC_OS_X_VERSION_MIN_REQUIRED < 1030
/*
@@ -331,8 +321,8 @@ TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
- return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
- Tcl_FSGetNativePath(destPathPtr));
+ return DoRenameFile((const char *)Tcl_FSGetNativePath(srcPathPtr),
+ (const char *)Tcl_FSGetNativePath(destPathPtr));
}
static int
@@ -447,14 +437,14 @@ TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
- const char *src = Tcl_FSGetNativePath(srcPathPtr);
+ const char *src = (const char *)Tcl_FSGetNativePath(srcPathPtr);
Tcl_StatBuf srcStatBuf;
if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
- return DoCopyFile(src, Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
+ return DoCopyFile(src, (const char *)Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
}
static int
@@ -610,7 +600,7 @@ TclUnixCopyFile(
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
- buffer = ckalloc(blockSize);
+ buffer = (char *)ckalloc(blockSize);
while (1) {
nread = (size_t) read(srcFd, buffer, blockSize);
if ((nread == (size_t) -1) || (nread == 0)) {
@@ -709,7 +699,7 @@ int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
- return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
+ return DoCreateDirectory((const char *)Tcl_FSGetNativePath(pathPtr));
}
static int
@@ -789,7 +779,7 @@ TclpObjCopyDirectory(
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
- *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE);
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
@@ -843,7 +833,7 @@ TclpObjRemoveDirectory(
Tcl_DStringFree(&pathString);
if (ret != TCL_OK) {
- *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE);
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
@@ -893,7 +883,7 @@ DoRemoveDirectory(
result = TCL_OK;
if ((errno != EEXIST) || (recursive == 0)) {
if (errorPtr != NULL) {
- Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
+ Tcl_ExternalToUtfDString(NULL, path, TCL_INDEX_NONE, errorPtr);
}
result = TCL_ERROR;
}
@@ -974,7 +964,7 @@ TraverseUnixTree(
errfile = NULL;
result = TCL_OK;
- targetLen = 0; /* lint. */
+ targetLen = 0;
source = Tcl_DStringValue(sourcePtr);
if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
@@ -1025,9 +1015,9 @@ TraverseUnixTree(
* Append name after slash, and recurse on the file.
*/
- Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1);
+ Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, TCL_INDEX_NONE);
if (targetPtr != NULL) {
- Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1);
+ Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, TCL_INDEX_NONE);
}
result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
errorPtr, doRewind);
@@ -1142,7 +1132,7 @@ TraverseUnixTree(
end:
if (errfile != NULL) {
if (errorPtr != NULL) {
- Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr);
+ Tcl_ExternalToUtfDString(NULL, errfile, TCL_INDEX_NONE, errorPtr);
}
result = TCL_ERROR;
}
@@ -1240,14 +1230,14 @@ TraversalCopy(
static int
TraversalDelete(
Tcl_DString *srcPtr, /* Source pathname (native). */
- Tcl_DString *ignore, /* Destination pathname (not used). */
- const Tcl_StatBuf *statBufPtr,
- /* Stat info for file specified by srcPtr. */
+ TCL_UNUSED(Tcl_DString *),
+ TCL_UNUSED(const Tcl_StatBuf *),
int type, /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
+
switch (type) {
case DOTREE_F:
if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
@@ -1289,7 +1279,11 @@ TraversalDelete(
static int
CopyFileAtts(
- const char *src, /* Path name of source file (native). */
+#ifdef MAC_OSX_TCL
+ const char *src, /* Path name of source file (native). */
+#else
+ TCL_UNUSED(const char *) /*src*/,
+#endif
const char *dst, /* Path name of target file (native). */
const Tcl_StatBuf *statBufPtr)
/* Stat info for source file */
@@ -1315,8 +1309,8 @@ CopyFileAtts(
}
}
- tval.actime = statBufPtr->st_atime;
- tval.modtime = statBufPtr->st_mtime;
+ tval.actime = Tcl_GetAccessTimeFromStat(statBufPtr);
+ tval.modtime = Tcl_GetModificationTimeFromStat(statBufPtr);
if (utime(dst, &tval)) { /* INTL: Native. */
return TCL_ERROR;
@@ -1347,7 +1341,7 @@ CopyFileAtts(
static int
GetGroupAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
@@ -1369,13 +1363,13 @@ GetGroupAttribute(
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
- TclNewIntObj(*attributePtrPtr, (int) statBuf.st_gid);
+ TclNewIntObj(*attributePtrPtr, statBuf.st_gid);
} else {
Tcl_DString ds;
const char *utf;
- utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds);
- *attributePtrPtr = Tcl_NewStringObj(utf, -1);
+ utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, TCL_INDEX_NONE, &ds);
+ *attributePtrPtr = Tcl_NewStringObj(utf, TCL_INDEX_NONE);
Tcl_DStringFree(&ds);
}
return TCL_OK;
@@ -1401,7 +1395,7 @@ GetGroupAttribute(
static int
GetOwnerAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
@@ -1423,12 +1417,12 @@ GetOwnerAttribute(
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
- TclNewIntObj(*attributePtrPtr, (int) statBuf.st_uid);
+ TclNewIntObj(*attributePtrPtr, statBuf.st_uid);
} else {
Tcl_DString ds;
- (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
- *attributePtrPtr = TclDStringToObj(&ds);
+ (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, TCL_INDEX_NONE, &ds);
+ *attributePtrPtr = Tcl_DStringToObj(&ds);
}
return TCL_OK;
}
@@ -1453,7 +1447,7 @@ GetOwnerAttribute(
static int
GetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
@@ -1472,7 +1466,7 @@ GetPermissionsAttribute(
}
*attributePtrPtr = Tcl_ObjPrintf(
- "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));
+ "%0#5o", ((int)statBuf.st_mode & 0x7FFF));
return TCL_OK;
}
@@ -1495,23 +1489,22 @@ GetPermissionsAttribute(
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New group for file. */
{
- long gid;
+ Tcl_WideInt gid;
int result;
const char *native;
- if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
- int length;
- string = Tcl_GetStringFromObj(attributePtr, &length);
+ string = TclGetString(attributePtr);
- native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
+ native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
@@ -1529,7 +1522,7 @@ SetGroupAttribute(
gid = groupPtr->gr_gid;
}
- native = Tcl_FSGetNativePath(fileName);
+ native = (const char *)Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
if (result != 0) {
@@ -1562,23 +1555,22 @@ SetGroupAttribute(
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New owner for file. */
{
- long uid;
+ Tcl_WideInt uid;
int result;
const char *native;
- if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
- int length;
- string = Tcl_GetStringFromObj(attributePtr, &length);
+ string = TclGetString(attributePtr);
- native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
+ native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
@@ -1596,7 +1588,7 @@ SetOwnerAttribute(
uid = pwPtr->pw_uid;
}
- native = Tcl_FSGetNativePath(fileName);
+ native = (const char *)Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
if (result != 0) {
@@ -1629,11 +1621,11 @@ SetOwnerAttribute(
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
- long mode;
+ Tcl_WideInt mode;
mode_t newMode;
int result = TCL_ERROR;
const char *native;
@@ -1652,11 +1644,11 @@ SetPermissionsAttribute(
TclNewLiteralStringObj(modeObj, "0o");
Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1);
- result = Tcl_GetLongFromObj(NULL, modeObj, &mode);
+ result = Tcl_GetWideIntFromObj(NULL, modeObj, &mode);
Tcl_DecrRefCount(modeObj);
}
if (result == TCL_OK
- || Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
+ || Tcl_GetWideIntFromObj(NULL, attributePtr, &mode) == TCL_OK) {
newMode = (mode_t) (mode & 0x00007FFF);
} else {
Tcl_StatBuf buf;
@@ -1690,7 +1682,7 @@ SetPermissionsAttribute(
}
}
- native = Tcl_FSGetNativePath(fileName);
+ native = (const char *)Tcl_FSGetNativePath(fileName);
result = chmod(native, newMode); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
@@ -1751,7 +1743,7 @@ TclpObjListVolumes(void)
static int
GetModeFromPermString(
- Tcl_Interp *interp, /* The interp we are using for errors. */
+ TCL_UNUSED(Tcl_Interp *),
const char *modeStringPtr, /* Permissions string */
mode_t *modePtr) /* pointer to the mode value */
{
@@ -1924,55 +1916,52 @@ GetModeFromPermString(
*
* TclpObjNormalizePath --
*
- * This function scans through a path specification and replaces it, in
- * place, with a normalized version. A normalized version is one in which
- * all symlinks in the path are replaced with their expanded form (except
- * a symlink at the very end of the path).
+ * Replaces each component except that last one in a pathname that is a
+ * symbolic link with the fully resolved target of that link.
*
* Results:
- * The new 'nextCheckpoint' value, giving as far as we could understand
- * in the path.
+ * Stores the resulting path in pathPtr and returns the offset of the last
+ * byte processed to obtain the resulting path.
*
* Side effects:
- * The pathPtr string, is modified.
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
- Tcl_Interp *interp,
- Tcl_Obj *pathPtr,
- int nextCheckpoint)
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *pathPtr, /* An unshared object containing the path to
+ * normalize. */
+ int nextCheckpoint) /* offset to start at in pathPtr. Must either
+ * be 0 or the offset of a directory separator
+ * at the end of a path part that is already
+ * normalized. I.e. this is not the index of
+ * the byte just after the separator. */
+
{
const char *currentPathEndPosition;
- int pathLen;
char cur;
- const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = TclGetString(pathPtr);
+ size_t pathLen = pathPtr->length;
Tcl_DString ds;
const char *nativePath;
#ifndef NO_REALPATH
char normPath[MAXPATHLEN];
#endif
- /*
- * We add '1' here because if nextCheckpoint is zero we know that '/'
- * exists, and if it isn't zero, it must point at a directory separator
- * which we also know exists.
- */
-
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
}
#ifndef NO_REALPATH
- /*
- * For speed, try to get the entire path in one go.
- */
-
if (nextCheckpoint == 0 && haveRealpath) {
- char *lastDir = strrchr(currentPathEndPosition, '/');
+ /*
+ * Try to get the entire path in one go
+ */
+
+ const char *lastDir = strrchr(currentPathEndPosition, '/');
if (lastDir != NULL) {
nativePath = Tcl_UtfToExternalDString(NULL, path,
@@ -1980,8 +1969,13 @@ TclpObjNormalizePath(
if (Realpath(nativePath, normPath) != NULL) {
if (*nativePath != '/' && *normPath == '/') {
/*
- * realpath has transformed a relative path into an
- * absolute path, we do not know how to handle this.
+ * realpath transformed a relative path into an
+ * absolute path. Fall back to the long way.
+ */
+
+ /*
+ * To do: This logic seems to be out of date. This whole
+ * routine should be reviewed and cleaed up.
*/
} else {
nextCheckpoint = lastDir - path;
@@ -2020,13 +2014,13 @@ TclpObjNormalizePath(
}
/*
- * Update the acceptable point.
+ * Assign the end of the current component to nextCheckpoint
*/
nextCheckpoint = currentPathEndPosition - path;
} else if (cur == 0) {
/*
- * Reached end of string.
+ * The end of the string.
*/
break;
@@ -2035,22 +2029,19 @@ TclpObjNormalizePath(
}
/*
- * We should really now convert this to a canonical path. We do that with
- * 'realpath' if we have it available. Otherwise we could step through
- * every single path component, checking whether it is a symlink, but that
- * would be a lot of work, and most modern OSes have 'realpath'.
+ * Call 'realpath' to obtain a canonical path.
*/
#ifndef NO_REALPATH
if (haveRealpath) {
- /*
- * If we only had '/foo' or '/' then we never increment nextCheckpoint
- * and we don't need or want to go through 'Realpath'. Also, on some
- * platforms, passing an empty string to 'Realpath' will give us the
- * normalized pwd, which is not what we want at all!
- */
-
if (nextCheckpoint == 0) {
+ /*
+ * The path contains at most one component, e.g. '/foo' or '/', so
+ * so there is nothing to resolve. Also, on some platforms
+ * 'Realpath' transforms an empty string into the normalized pwd,
+ * which is the wrong answer.
+ */
+
return 0;
}
@@ -2063,18 +2054,19 @@ TclpObjNormalizePath(
if ((newNormLen == Tcl_DStringLength(&ds))
&& (strcmp(normPath, nativePath) == 0)) {
/*
- * String is unchanged.
+ * The original path is unchanged.
*/
Tcl_DStringFree(&ds);
/*
- * Enable this to have the native FS claim normalization of
- * the whole path for existing files. That would permit the
- * caller to declare normalization complete without calls to
- * additional filesystems. Saving lots of calls is probably
- * worth the extra access() time here. When no other FS's are
- * registered though, things are less clear.
+ * Uncommenting this would mean that this native filesystem
+ * routine claims the path is normalized if the file exists,
+ * which would permit the caller to avoid iterating through
+ * other filesystems filesystems. Saving lots of calls is
+ * probably worth the extra access() time, but in the common
+ * case that no other filesystems are registered this is an
+ * unnecessary expense.
*
if (0 == access(normPath, F_OK)) {
return pathLen;
@@ -2085,8 +2077,7 @@ TclpObjNormalizePath(
}
/*
- * Free up the native path and put in its place the converted,
- * normalized path.
+ * Free the original path and replace it with the normalized path.
*/
Tcl_DStringFree(&ds);
@@ -2094,7 +2085,7 @@ TclpObjNormalizePath(
if (path[nextCheckpoint] != '\0') {
/*
- * Not at end, append remaining path.
+ * Append the remaining path components.
*/
int normLen = Tcl_DStringLength(&ds);
@@ -2103,7 +2094,8 @@ TclpObjNormalizePath(
pathLen - nextCheckpoint);
/*
- * We recognise up to and including the directory separator.
+ * characters up to and including the directory separator have
+ * been processed
*/
nextCheckpoint = normLen + 1;
@@ -2115,10 +2107,6 @@ TclpObjNormalizePath(
nextCheckpoint = Tcl_DStringLength(&ds);
}
- /*
- * Overwrite with the normalized path.
- */
-
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
}
@@ -2175,56 +2163,56 @@ TclUnixOpenTemporaryFile(
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
- Tcl_DString template, tmp;
+ Tcl_DString templ, tmp;
const char *string;
- int len, fd;
+ int fd;
/*
* We should also check against making more then TMP_MAX of these.
*/
if (dirObj) {
- string = Tcl_GetStringFromObj(dirObj, &len);
- Tcl_UtfToExternalDString(NULL, string, len, &template);
+ string = TclGetString(dirObj);
+ Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ);
} else {
- Tcl_DStringInit(&template);
- Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */
+ Tcl_DStringInit(&templ);
+ Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */
}
- TclDStringAppendLiteral(&template, "/");
+ TclDStringAppendLiteral(&templ, "/");
if (basenameObj) {
- string = Tcl_GetStringFromObj(basenameObj, &len);
- Tcl_UtfToExternalDString(NULL, string, len, &tmp);
- TclDStringAppendDString(&template, &tmp);
+ string = TclGetString(basenameObj);
+ Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
+ TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
- TclDStringAppendLiteral(&template, "tcl");
+ TclDStringAppendLiteral(&templ, "tcl");
}
- TclDStringAppendLiteral(&template, "_XXXXXX");
+ TclDStringAppendLiteral(&templ, "_XXXXXX");
#ifdef HAVE_MKSTEMPS
if (extensionObj) {
- string = Tcl_GetStringFromObj(extensionObj, &len);
- Tcl_UtfToExternalDString(NULL, string, len, &tmp);
- TclDStringAppendDString(&template, &tmp);
- fd = mkstemps(Tcl_DStringValue(&template), Tcl_DStringLength(&tmp));
+ string = TclGetString(extensionObj);
+ Tcl_UtfToExternalDString(NULL, string, extensionObj->length, &tmp);
+ TclDStringAppendDString(&templ, &tmp);
+ fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else
#endif
{
- fd = mkstemp(Tcl_DStringValue(&template));
+ fd = mkstemp(Tcl_DStringValue(&templ));
}
if (fd == -1) {
- Tcl_DStringFree(&template);
+ Tcl_DStringFree(&templ);
return -1;
}
if (resultingNameObj) {
- Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template),
- Tcl_DStringLength(&template), &tmp);
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ),
+ Tcl_DStringLength(&templ), &tmp);
Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp),
Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
@@ -2235,10 +2223,10 @@ TclUnixOpenTemporaryFile(
* this!
*/
- unlink(Tcl_DStringValue(&template));
+ unlink(Tcl_DStringValue(&templ));
errno = 0;
}
- Tcl_DStringFree(&template);
+ Tcl_DStringFree(&templ);
return fd;
}
@@ -2251,17 +2239,17 @@ static const char *
DefaultTempDir(void)
{
const char *dir;
- struct stat buf;
+ Tcl_StatBuf buf;
dir = getenv("TMPDIR");
- if (dir && dir[0] && stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode)
+ if (dir && dir[0] && TclOSstat(dir, &buf) == 0 && S_ISDIR(buf.st_mode)
&& access(dir, W_OK) == 0) {
return dir;
}
#ifdef P_tmpdir
dir = P_tmpdir;
- if (stat(dir, &buf)==0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)==0) {
+ if (TclOSstat(dir, &buf)==0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)==0) {
return dir;
}
#endif
@@ -2275,6 +2263,85 @@ DefaultTempDir(void)
return TCL_TEMPORARY_FILE_DIRECTORY;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateTemporaryDirectory --
+ *
+ * Creates a temporary directory, possibly based on the supplied bits and
+ * pieces of template supplied in the arguments.
+ *
+ * Results:
+ * An object (refcount 0) containing the name of the newly-created
+ * directory, or NULL on failure.
+ *
+ * Side effects:
+ * Accesses the native filesystem. Makes a directory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclpCreateTemporaryDirectory(
+ Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj)
+{
+ Tcl_DString templ, tmp;
+ const char *string;
+
+#define DEFAULT_TEMP_DIR_PREFIX "tcl"
+
+ /*
+ * Build the template in writable memory from the user-supplied pieces and
+ * some defaults.
+ */
+
+ if (dirObj) {
+ string = TclGetString(dirObj);
+ Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ);
+ } else {
+ Tcl_DStringInit(&templ);
+ Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */
+ }
+
+ if (Tcl_DStringValue(&templ)[Tcl_DStringLength(&templ) - 1] != '/') {
+ TclDStringAppendLiteral(&templ, "/");
+ }
+
+ if (basenameObj) {
+ string = TclGetString(basenameObj);
+ if (basenameObj->length) {
+ Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
+ TclDStringAppendDString(&templ, &tmp);
+ Tcl_DStringFree(&tmp);
+ } else {
+ TclDStringAppendLiteral(&templ, DEFAULT_TEMP_DIR_PREFIX);
+ }
+ } else {
+ TclDStringAppendLiteral(&templ, DEFAULT_TEMP_DIR_PREFIX);
+ }
+
+ TclDStringAppendLiteral(&templ, "_XXXXXX");
+
+ /*
+ * Make the temporary directory.
+ */
+
+ if (mkdtemp(Tcl_DStringValue(&templ)) == NULL) {
+ Tcl_DStringFree(&templ);
+ return NULL;
+ }
+
+ /*
+ * The template has been updated. Tell the caller what it was.
+ */
+
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ),
+ Tcl_DStringLength(&templ), &tmp);
+ Tcl_DStringFree(&templ);
+ return Tcl_DStringToObj(&tmp);
+}
+
#if defined(__CYGWIN__)
static void
@@ -2283,7 +2350,7 @@ StatError(
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
@@ -2293,42 +2360,45 @@ winPathFromObj(
Tcl_Obj *fileName)
{
int size;
- const char *native = Tcl_FSGetNativePath(fileName);
+ const char *native = (const char *)Tcl_FSGetNativePath(fileName);
WCHAR *winPath;
size = cygwin_conv_path(1, native, NULL, 0);
- winPath = ckalloc(size);
+ winPath = (WCHAR *)ckalloc(size);
cygwin_conv_path(1, native, winPath, size);
return winPath;
}
static const int attributeArray[] = {
- 0x20, 0, 2, 0, 0, 1, 4};
+ 0x20, 0, 2, 0, 0, 1, 4
+};
/*
*----------------------------------------------------------------------
*
* GetUnixFileAttributes
*
- * Gets the readonly attribute of a file.
+ * Gets an attribute of a file.
*
* Results:
- * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
- * is no error. The object will have ref count 0.
+ * A standard Tcl result.
*
* Side effects:
- * A new object is allocated.
+ * If there is no error assigns to *attributePtrPtr the address of a new
+ * Tcl_Obj having a refCount of zero and containing the value of the
+ * specified attribute.
+ *
*
*----------------------------------------------------------------------
*/
static int
GetUnixFileAttributes(
- Tcl_Interp *interp, /* The interp we are using for errors. */
+ Tcl_Interp *interp, /* The interp to report errors to. */
int objIndex, /* The index of the attribute. */
- Tcl_Obj *fileName, /* The name of the file (UTF-8). */
- Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
+ Tcl_Obj *fileName, /* The pathname of the file (UTF-8). */
+ Tcl_Obj **attributePtrPtr) /* Where to store the result. */
{
int fileAttributes;
WCHAR *winPath = winPathFromObj(fileName);
@@ -2341,8 +2411,8 @@ GetUnixFileAttributes(
return TCL_ERROR;
}
- TclNewIntObj(*attributePtrPtr, (fileAttributes&attributeArray[objIndex])!=0);
-
+ TclNewIntObj(*attributePtrPtr,
+ (fileAttributes & attributeArray[objIndex]) != 0);
return TCL_OK;
}
@@ -2399,7 +2469,7 @@ SetUnixFileAttributes(
return TCL_ERROR;
}
- ckfree(winPath);
+ ckfree(winPath);
return TCL_OK;
}
#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
@@ -2423,7 +2493,7 @@ SetUnixFileAttributes(
static int
GetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
@@ -2441,8 +2511,7 @@ GetUnixFileAttributes(
return TCL_ERROR;
}
- *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE);
-
+ TclNewIntObj(*attributePtrPtr, (statBuf.st_flags & UF_IMMUTABLE) != 0);
return TCL_OK;
}
@@ -2465,7 +2534,7 @@ GetUnixFileAttributes(
static int
SetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
@@ -2494,7 +2563,7 @@ SetUnixFileAttributes(
statBuf.st_flags &= ~UF_IMMUTABLE;
}
- native = Tcl_FSGetNativePath(fileName);
+ native = (const char *)Tcl_FSGetNativePath(fileName);
result = chflags(native, statBuf.st_flags); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 1d1d729..aecdb3b 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -4,7 +4,7 @@
* This file contains wrappers around UNIX file handling functions.
* These wrappers mask differences between Windows and UNIX.
*
- * Copyright (c) 1995-1998 Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -34,13 +34,12 @@ static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry,
*---------------------------------------------------------------------------
*/
+#ifdef __CYGWIN__
void
TclpFindExecutable(
- const char *argv0) /* The value of the application's argv[0]
- * (native). */
+ TCL_UNUSED(const char *) /*argv0*/)
{
-#ifdef __CYGWIN__
- int length;
+ size_t length;
wchar_t buf[PATH_MAX] = L"";
char name[PATH_MAX * 3 + 1];
@@ -53,7 +52,13 @@ TclpFindExecutable(
}
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), NULL);
+}
#else
+void
+TclpFindExecutable(
+ const char *argv0) /* The value of the application's argv[0]
+ * (native). */
+{
Tcl_Encoding encoding;
const char *name, *p;
Tcl_StatBuf statBuf;
@@ -112,7 +117,7 @@ TclpFindExecutable(
TclDStringAppendLiteral(&buffer, "/");
}
}
- name = Tcl_DStringAppend(&buffer, argv0, -1);
+ name = Tcl_DStringAppend(&buffer, argv0, TCL_INDEX_NONE);
/*
* INTL: The following calls to access() and stat() should not be
@@ -148,9 +153,9 @@ TclpFindExecutable(
#endif
{
encoding = Tcl_GetEncoding(NULL, NULL);
- Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
+ Tcl_ExternalToUtfDString(encoding, name, TCL_INDEX_NONE, &utfName);
TclSetObjNameOfExecutable(
- Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
+ Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding);
Tcl_DStringFree(&utfName);
goto done;
}
@@ -171,7 +176,7 @@ TclpFindExecutable(
}
Tcl_DStringInit(&nameString);
- Tcl_DStringAppend(&nameString, name, -1);
+ Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
@@ -184,16 +189,16 @@ TclpFindExecutable(
Tcl_DStringFree(&nameString);
encoding = Tcl_GetEncoding(NULL, NULL);
- Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
+ Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE,
&utfName);
TclSetObjNameOfExecutable(
- Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
+ Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
-#endif
}
+#endif
/*
*----------------------------------------------------------------------
@@ -262,14 +267,15 @@ TclpMatchInDirectory(
TclDIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
- int dirLength, nativeDirLen;
+ size_t dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
- dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
+ dirName = TclGetString(fileNamePtr);
+ dirLength = fileNamePtr->length;
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
@@ -299,7 +305,7 @@ TclpMatchInDirectory(
* Now open the directory for reading and iterate over the contents.
*/
- native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, dirName, TCL_INDEX_NONE, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
@@ -363,14 +369,14 @@ TclpMatchInDirectory(
* and pattern. If so, add the file to the result.
*/
- utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
+ utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, TCL_INDEX_NONE,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
- native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
+ native = Tcl_DStringAppend(&ds, entryPtr->d_name, TCL_INDEX_NONE);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
@@ -554,6 +560,8 @@ NativeMatchType(
return matchResult;
}
}
+#else
+ (void)interp;
#endif /* MAC_OSX_TCL */
return 1;
@@ -588,7 +596,7 @@ TclpGetUserHome(
{
struct passwd *pwPtr;
Tcl_DString ds;
- const char *native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
+ const char *native = Tcl_UtfToExternalDString(NULL, name, TCL_INDEX_NONE, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
@@ -596,7 +604,7 @@ TclpGetUserHome(
if (pwPtr == NULL) {
return NULL;
}
- Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
+ Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, TCL_INDEX_NONE, bufferPtr);
return Tcl_DStringValue(bufferPtr);
}
@@ -621,7 +629,7 @@ TclpObjAccess(
Tcl_Obj *pathPtr, /* Path of file to access */
int mode) /* Permission setting. */
{
- const char *path = Tcl_FSGetNativePath(pathPtr);
+ const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
@@ -775,7 +783,7 @@ TclpGetCwd(
}
return NULL;
}
- return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
+ return Tcl_ExternalToUtfDString(NULL, buffer, TCL_INDEX_NONE, bufferPtr);
}
/*
@@ -810,7 +818,7 @@ TclpReadlink(
const char *native;
Tcl_DString ds;
- native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, path, TCL_INDEX_NONE, &ds);
length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
@@ -937,7 +945,6 @@ TclpObjLink(
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
- int targetLen;
Tcl_DString ds;
Tcl_Obj *transPtr;
@@ -951,8 +958,8 @@ TclpObjLink(
if (transPtr == NULL) {
return NULL;
}
- target = Tcl_GetStringFromObj(transPtr, &targetLen);
- target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
+ target = TclGetString(transPtr);
+ target = Tcl_UtfToExternalDString(NULL, target, transPtr->length, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
@@ -988,7 +995,7 @@ TclpObjLink(
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
- linkPtr = TclDStringToObj(&ds);
+ linkPtr = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
return linkPtr;
}
@@ -1016,7 +1023,7 @@ TclpObjLink(
Tcl_Obj *
TclpFilesystemPathType(
- Tcl_Obj *pathPtr)
+ TCL_UNUSED(Tcl_Obj *))
{
/*
* All native paths are of the same type.
@@ -1052,8 +1059,8 @@ TclpNativeToNormalized(
{
Tcl_DString ds;
- Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds);
- return TclDStringToObj(&ds);
+ Tcl_ExternalToUtfDString(NULL, (const char *) clientData, TCL_INDEX_NONE, &ds);
+ return Tcl_DStringToObj(&ds);
}
/*
@@ -1080,7 +1087,7 @@ TclNativeCreateNativeRep(
const char *str;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
- int len;
+ size_t len;
if (TclFSCwdIsNative()) {
/*
@@ -1105,7 +1112,8 @@ TclNativeCreateNativeRep(
Tcl_IncrRefCount(validPathPtr);
}
- str = Tcl_GetStringFromObj(validPathPtr, &len);
+ str = TclGetString(validPathPtr);
+ len = validPathPtr->length;
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
@@ -1188,6 +1196,29 @@ TclpUtime(
#ifdef __CYGWIN__
int
+TclOSfstat(
+ int fd,
+ void *cygstat)
+{
+ struct stat buf;
+ Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
+ int result = fstat(fd, &buf);
+
+ statBuf->st_mode = buf.st_mode;
+ statBuf->st_ino = buf.st_ino;
+ statBuf->st_dev = buf.st_dev;
+ statBuf->st_rdev = buf.st_rdev;
+ statBuf->st_nlink = buf.st_nlink;
+ statBuf->st_uid = buf.st_uid;
+ statBuf->st_gid = buf.st_gid;
+ statBuf->st_size = buf.st_size;
+ statBuf->st_atime = buf.st_atime;
+ statBuf->st_mtime = buf.st_mtime;
+ statBuf->st_ctime = buf.st_ctime;
+ return result;
+}
+
+int
TclOSstat(
const char *name,
void *cygstat)
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index 2d17027..ce08425 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -3,14 +3,12 @@
*
* Contains the Unix-specific interpreter initialization functions.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation.
* All rights reserved.
*/
#include "tclInt.h"
-#include <stddef.h>
-#include <locale.h>
#ifdef HAVE_LANGINFO
# include <langinfo.h>
# ifdef __APPLE__
@@ -325,7 +323,7 @@ static int MacOSXGetLibraryPath(Tcl_Interp *interp,
#endif /* HAVE_COREFOUNDATION */
#if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \
defined(MAC_OS_X_VERSION_MIN_REQUIRED) && ( \
- (defined(TCL_THREADS) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030) || \
+ (TCL_THREADS && MAC_OS_X_VERSION_MIN_REQUIRED < 1030) || \
(defined(__LP64__) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050) || \
(defined(HAVE_COREFOUNDATION) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050)\
)))
@@ -371,13 +369,13 @@ TclpInitPlatform(void)
* Make sure, that the standard FDs exist. [Bug 772288]
*/
- if (TclOSseek(0, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
+ if (TclOSseek(0, 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_RDONLY);
}
- if (TclOSseek(1, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
+ if (TclOSseek(1, 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_WRONLY);
}
- if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
+ if (TclOSseek(2, 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_WRONLY);
}
@@ -395,14 +393,6 @@ TclpInitPlatform(void)
#endif /* SIGPIPE */
#if defined(__FreeBSD__) && defined(__GNUC__)
- /*
- * Adjust the rounding mode to be more conventional. Note that FreeBSD
- * only provides the __fpsetreg() used by the following two for the GNU
- * Compiler. When using, say, Intel's icc they break. (Partially based on
- * patch in BSD ports system from root@celsius.bychok.com)
- */
-
- fpsetround(FP_RN);
(void) fpsetmask(0L);
#endif
@@ -428,7 +418,7 @@ TclpInitPlatform(void)
/*
* In case the initial locale is not "C", ensure that the numeric
* processing is done in "C" locale regardless. This is needed because Tcl
- * relies on routines like strtod, but should not have locale dependent
+ * relies on routines like strtol/strtoul, but should not have locale dependent
* behavior.
*/
@@ -465,7 +455,7 @@ TclpInitPlatform(void)
void
TclpInitLibraryPath(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
@@ -483,7 +473,7 @@ TclpInitLibraryPath(
*/
str = getenv("TCL_LIBRARY"); /* INTL: Native. */
- Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
+ Tcl_ExternalToUtfDString(NULL, str, TCL_INDEX_NONE, &buffer);
str = Tcl_DStringValue(&buffer);
if ((str != NULL) && (str[0] != '\0')) {
@@ -506,7 +496,7 @@ TclpInitLibraryPath(
* If TCL_LIBRARY is set, search there.
*/
- Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, -1));
+ Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, TCL_INDEX_NONE));
Tcl_SplitPath(str, &pathc, &pathv);
if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
@@ -520,7 +510,7 @@ TclpInitLibraryPath(
pathv[pathc - 1] = installLib + 4;
str = Tcl_JoinPath(pathc, pathv, &ds);
- Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds));
+ Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_DStringToObj(&ds));
}
ckfree(pathv);
}
@@ -547,14 +537,15 @@ TclpInitLibraryPath(
str = defaultLibraryDir;
}
if (str[0] != '\0') {
- objPtr = Tcl_NewStringObj(str, -1);
+ objPtr = Tcl_NewStringObj(str, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
- str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
+ str = TclGetString(pathPtr);
+ *lengthPtr = pathPtr->length;
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, str, *lengthPtr + 1);
Tcl_DecrRefCount(pathPtr);
@@ -644,13 +635,13 @@ Tcl_GetEncodingNameFromEnvironment(
*/
Tcl_DStringInit(&ds);
- encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
+ encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), TCL_INDEX_NONE);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
- Tcl_DStringAppend(bufPtr, knownEncoding, -1);
+ Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
- Tcl_DStringAppend(bufPtr, encoding, -1);
+ Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE);
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
@@ -682,14 +673,14 @@ Tcl_GetEncodingNameFromEnvironment(
Tcl_DStringInit(&ds);
p = encoding;
- encoding = Tcl_DStringAppend(&ds, p, -1);
+ encoding = Tcl_DStringAppend(&ds, p, TCL_INDEX_NONE);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
- Tcl_DStringAppend(bufPtr, knownEncoding, -1);
+ Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
- Tcl_DStringAppend(bufPtr, encoding, -1);
+ Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(bufPtr)) {
Tcl_DStringFree(&ds);
@@ -710,9 +701,9 @@ Tcl_GetEncodingNameFromEnvironment(
if (*p != '\0') {
knownEncoding = SearchKnownEncodings(p);
if (knownEncoding != NULL) {
- Tcl_DStringAppend(bufPtr, knownEncoding, -1);
+ Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE);
} else if (NULL != Tcl_GetEncoding(NULL, p)) {
- Tcl_DStringAppend(bufPtr, p, -1);
+ Tcl_DStringAppend(bufPtr, p, TCL_INDEX_NONE);
}
}
Tcl_DStringFree(&ds);
@@ -720,7 +711,7 @@ Tcl_GetEncodingNameFromEnvironment(
return Tcl_DStringValue(bufPtr);
}
}
- return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1);
+ return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, TCL_INDEX_NONE);
}
/*
@@ -913,7 +904,7 @@ TclpSetVariables(
unameOK = 1;
- native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds);
+ native = Tcl_ExternalToUtfDString(NULL, name.sysname, TCL_INDEX_NONE, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
@@ -976,7 +967,7 @@ TclpSetVariables(
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
- user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds);
+ user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, TCL_INDEX_NONE, &ds);
}
Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
@@ -1025,7 +1016,7 @@ TclpFindVariable(
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
- p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
+ p1 = Tcl_ExternalToUtfDString(NULL, env, TCL_INDEX_NONE, &envString);
p2 = name;
for (; *p2 == *p1; p1++, p2++) {
@@ -1065,22 +1056,27 @@ TclpFindVariable(
*/
#ifdef HAVE_COREFOUNDATION
+#ifdef TCL_FRAMEWORK
static int
MacOSXGetLibraryPath(
Tcl_Interp *interp,
int maxPathLen,
char *tclLibPath)
{
- int foundInFramework = TCL_ERROR;
-
-#ifdef TCL_FRAMEWORK
- foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp,
+ return Tcl_MacOSXOpenVersionedBundleResources(interp,
"com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen,
tclLibPath);
-#endif
-
- return foundInFramework;
}
+#else
+static int
+MacOSXGetLibraryPath(
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int),
+ TCL_UNUSED(char *))
+{
+ return TCL_ERROR;
+}
+#endif
#endif /* HAVE_COREFOUNDATION */
/*
diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index 4655327..0a2b695 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -1,276 +1,43 @@
-#define AT_FORK_INIT_VALUE 0
-#define RESET_ATFORK_MUTEX 1
/*
- * tclUnixNotify.c --
+ * tclUnixNotfy.c --
*
- * This file contains the implementation of the select()-based
- * Unix-specific notifier, which is the lowest-level part of the Tcl
- * event loop. This file works together with generic/tclNotify.c.
+ * This file contains subroutines shared by all notifier backend
+ * implementations on *nix platforms. It is *included* by the epoll,
+ * kqueue and select notifier implementation files.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de>
+ * 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.
*/
+#include <poll.h>
#include "tclInt.h"
-#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
- * in tclMacOSXNotify.c */
-#include <signal.h>
-
-/*
- * This structure is used to keep track of the notifier info for a registered
- * file.
- */
-
-typedef struct FileHandler {
- int fd;
- int mask; /* Mask of desired events: TCL_READABLE,
- * etc. */
- int readyMask; /* Mask of events that have been seen since
- * the last time file handlers were invoked
- * for this file. */
- Tcl_FileProc *proc; /* Function to call, in the style of
- * Tcl_CreateFileHandler. */
- void *clientData; /* Argument to pass to proc. */
- struct FileHandler *nextPtr;/* Next in list of all files we care about. */
-} FileHandler;
-
-/*
- * The following structure is what is added to the Tcl event queue when file
- * handlers are ready to fire.
- */
-
-typedef struct FileHandlerEvent {
- Tcl_Event header; /* Information that is standard for all
- * events. */
- int fd; /* File descriptor that is ready. Used to find
- * the FileHandler structure for the file
- * (can't point directly to the FileHandler
- * structure because it could go away while
- * the event is queued). */
-} FileHandlerEvent;
-
-/*
- * The following structure contains a set of select() masks to track readable,
- * writable, and exception conditions.
- */
-
-typedef struct SelectMasks {
- fd_set readable;
- fd_set writable;
- fd_set exception;
-} SelectMasks;
-
-/*
- * The following static structure contains the state information for the
- * select based implementation of the Tcl notifier. One of these structures is
- * created for each thread that is using the notifier.
- */
-
-typedef struct ThreadSpecificData {
- FileHandler *firstFileHandlerPtr;
- /* Pointer to head of file handler list. */
- SelectMasks checkMasks; /* This structure is used to build up the
- * masks to be used in the next call to
- * select. Bits are set in response to calls
- * to Tcl_CreateFileHandler. */
- SelectMasks readyMasks; /* This array reflects the readable/writable
- * conditions that were found to exist by the
- * last call to select. */
- int numFdBits; /* Number of valid bits in checkMasks (one
- * more than highest fd for which
- * Tcl_WatchFile has been called). */
-#ifdef TCL_THREADS
- int onList; /* True if it is in this list */
- unsigned int pollState; /* pollState is used to implement a polling
- * handshake between each thread and the
- * notifier thread. Bits defined below. */
- struct ThreadSpecificData *nextPtr, *prevPtr;
- /* All threads that are currently waiting on
- * an event have their ThreadSpecificData
- * structure on a doubly-linked listed formed
- * from these pointers. You must hold the
- * notifierMutex lock before accessing these
- * fields. */
-#ifdef __CYGWIN__
- void *event; /* Any other thread alerts a notifier that an
- * event is ready to be processed by sending
- * this event. */
- void *hwnd; /* Messaging window. */
-#else /* !__CYGWIN__ */
- pthread_cond_t waitCV; /* Any other thread alerts a notifier that an
- * event is ready to be processed by signaling
- * this condition variable. */
-#endif /* __CYGWIN__ */
- int waitCVinitialized; /* Variable to flag initialization of the
- * structure. */
- int eventReady; /* True if an event is ready to be processed.
- * Used as condition flag together with waitCV
- * above. */
-#endif /* TCL_THREADS */
-} ThreadSpecificData;
-
-static Tcl_ThreadDataKey dataKey;
-
-#ifdef TCL_THREADS
-/*
- * The following static indicates the number of threads that have initialized
- * notifiers.
- *
- * You must hold the notifierMutex lock before accessing this variable.
- */
-
-static int notifierCount = 0;
-
-/*
- * The following variable points to the head of a doubly-linked list of
- * ThreadSpecificData structures for all threads that are currently waiting on
- * an event.
- *
- * You must hold the notifierMutex lock before accessing this list.
- */
-
-static ThreadSpecificData *waitingListPtr = NULL;
-
-/*
- * The notifier thread spends all its time in select() waiting for a file
- * descriptor associated with one of the threads on the waitingListPtr list to
- * do something interesting. But if the contents of the waitingListPtr list
- * ever changes, we need to wake up and restart the select() system call. You
- * can wake up the notifier thread by writing a single byte to the file
- * descriptor defined below. This file descriptor is the input-end of a pipe
- * and the notifier thread is listening for data on the output-end of the same
- * pipe. Hence writing to this file descriptor will cause the select() system
- * call to return and wake up the notifier thread.
- *
- * You must hold the notifierMutex lock before writing to the pipe.
- */
-
-static int triggerPipe = -1;
-
-/*
- * The notifierMutex locks access to all of the global notifier state.
- */
-
-static pthread_mutex_t notifierInitMutex = PTHREAD_MUTEX_INITIALIZER;
-static pthread_mutex_t notifierMutex = PTHREAD_MUTEX_INITIALIZER;
-/*
- * The following static indicates if the notifier thread is running.
- *
- * You must hold the notifierInitMutex before accessing this variable.
- */
-
-static int notifierThreadRunning = 0;
-
-/*
- * The notifier thread signals the notifierCV when it has finished
- * initializing the triggerPipe and right before the notifier thread
- * terminates.
- */
-
-static pthread_cond_t notifierCV = PTHREAD_COND_INITIALIZER;
-
-/*
- * The pollState bits:
- *
- * POLL_WANT is set by each thread before it waits on its condition variable.
- * It is checked by the notifier before it does select.
- *
- * POLL_DONE is set by the notifier if it goes into select after seeing
- * POLL_WANT. The idea is to ensure it tries a select with the same bits
- * the initial thread had set.
- */
-
-#define POLL_WANT 0x1
-#define POLL_DONE 0x2
-
-/*
- * This is the thread ID of the notifier thread that does select.
- */
-
-static Tcl_ThreadId notifierThread;
-#endif /* TCL_THREADS */
/*
* Static routines defined in this file.
*/
-#ifdef TCL_THREADS
-static void NotifierThreadProc(void *clientData);
-#if defined(HAVE_PTHREAD_ATFORK)
-static int atForkInit = AT_FORK_INIT_VALUE;
-static void AtForkPrepare(void);
-static void AtForkParent(void);
-static void AtForkChild(void);
-#endif /* HAVE_PTHREAD_ATFORK */
-#endif /* TCL_THREADS */
-static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
+static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
+#if !TCL_THREADS
+# undef NOTIFIER_EPOLL
+# undef NOTIFIER_KQUEUE
+# define NOTIFIER_SELECT
+#elif !defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE)
+# define NOTIFIER_SELECT
+static TCL_NORETURN void NotifierThreadProc(ClientData clientData);
+# if defined(HAVE_PTHREAD_ATFORK)
+static void AtForkChild(void);
+# endif /* HAVE_PTHREAD_ATFORK */
/*
- * Import of Windows API when building threaded with Cygwin.
- */
-
-#if defined(TCL_THREADS) && defined(__CYGWIN__)
-typedef struct {
- void *hwnd; /* Messaging window. */
- unsigned int *message; /* Message payload. */
- size_t wParam; /* Event-specific "word" parameter. */
- size_t lParam; /* Event-specific "long" parameter. */
- int time; /* Event timestamp. */
- int x; /* Event location (where meaningful). */
- int y;
- int lPrivate;
-} MSG;
-
-typedef struct {
- unsigned int style;
- void *lpfnWndProc;
- int cbClsExtra;
- int cbWndExtra;
- void *hInstance;
- void *hIcon;
- void *hCursor;
- void *hbrBackground;
- const void *lpszMenuName;
- const void *lpszClassName;
-} WNDCLASSW;
-
-extern void __stdcall CloseHandle(void *);
-extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
- void *);
-extern void * __stdcall CreateWindowExW(void *, const void *, const void *,
- unsigned int, int, int, int, int, void *, void *, void *, void *);
-extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *);
-extern unsigned char __stdcall DestroyWindow(void *);
-extern int __stdcall DispatchMessageW(const MSG *);
-extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
-extern void __stdcall MsgWaitForMultipleObjects(unsigned int, void *,
- unsigned char, unsigned int, unsigned int);
-extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
-extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *,
- void *);
-extern void __stdcall PostQuitMessage(int);
-extern void *__stdcall RegisterClassW(const WNDCLASSW *);
-extern unsigned char __stdcall ResetEvent(void *);
-extern unsigned char __stdcall TranslateMessage(const MSG *);
-
-/*
- * Threaded-cygwin specific constants and functions in this file:
- */
-
-static const wchar_t *NotfyClassName = L"TclNotifier";
-static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
- void *wParam, void *lParam);
-#endif /* TCL_THREADS && __CYGWIN__ */
-
-#if TCL_THREADS
-/*
*----------------------------------------------------------------------
*
* StartNotifierThread --
*
- * Start a notfier thread and wait for the notifier pipe to be created.
+ * Start a notifier thread and wait for the notifier pipe to be created.
*
* Results:
* None.
@@ -280,8 +47,10 @@ static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
*
*----------------------------------------------------------------------
*/
+
static void
-StartNotifierThread(const char *proc)
+StartNotifierThread(
+ const char *proc)
{
if (!notifierThreadRunning) {
pthread_mutex_lock(&notifierInitMutex);
@@ -292,6 +61,7 @@ StartNotifierThread(const char *proc)
}
pthread_mutex_lock(&notifierMutex);
+
/*
* Wait for the notifier pipe to be created.
*/
@@ -306,213 +76,127 @@ StartNotifierThread(const char *proc)
pthread_mutex_unlock(&notifierInitMutex);
}
}
-#endif /* TCL_THREADS */
+#endif /* NOTIFIER_SELECT */
/*
*----------------------------------------------------------------------
*
- * Tcl_InitNotifier --
+ * TclpAlertNotifier --
*
- * Initializes the platform specific notifier state.
+ * 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 on a
+ * given notifier after Tcl_FinalizeNotifier is called for that notifier.
*
* Results:
- * Returns a handle to the notifier state for this thread.
+ * None.
*
* Side effects:
- * None.
+ * select(2) notifier:
+ * signals the notifier condition variable for the specified
+ * notifier.
+ * epoll(7) notifier:
+ * write(2)s to the eventfd(2) of the specified thread.
+ * kqueue(2) notifier:
+ * write(2)s to the trigger pipe(2) of the specified thread.
*
*----------------------------------------------------------------------
*/
-void *
-Tcl_InitNotifier(void)
+void
+TclpAlertNotifier(
+ void *clientData)
{
- if (tclNotifierHooks.initNotifierProc) {
- return tclNotifierHooks.initNotifierProc();
- } else {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
-#ifdef TCL_THREADS
- tsdPtr->eventReady = 0;
-
- /*
- * Initialize thread specific condition variable for this thread.
- */
- if (tsdPtr->waitCVinitialized == 0) {
-#ifdef __CYGWIN__
- WNDCLASSW clazz;
+#ifdef NOTIFIER_SELECT
+#if TCL_THREADS
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
- clazz.style = 0;
- clazz.cbClsExtra = 0;
- clazz.cbWndExtra = 0;
- clazz.hInstance = TclWinGetTclInstance();
- clazz.hbrBackground = NULL;
- clazz.lpszMenuName = NULL;
- clazz.lpszClassName = NotfyClassName;
- clazz.lpfnWndProc = (void *)NotifierProc;
- clazz.hIcon = NULL;
- clazz.hCursor = NULL;
+ pthread_mutex_lock(&notifierMutex);
+ tsdPtr->eventReady = 1;
- RegisterClassW(&clazz);
- tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName,
- clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
- clazz.hInstance, NULL);
- tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
- 0 /* !signaled */, NULL);
+# ifdef __CYGWIN__
+ PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
+# else
+ pthread_cond_broadcast(&tsdPtr->waitCV);
+# endif /* __CYGWIN__ */
+ pthread_mutex_unlock(&notifierMutex);
#else
- pthread_cond_init(&tsdPtr->waitCV, NULL);
-#endif /* __CYGWIN__ */
- tsdPtr->waitCVinitialized = 1;
- }
-
- pthread_mutex_lock(&notifierInitMutex);
-#if defined(HAVE_PTHREAD_ATFORK)
- /*
- * Install pthread_atfork handlers to clean up the notifier in the
- * child of a fork.
- */
-
- if (!atForkInit) {
- int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);
-
- if (result) {
- Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed");
- }
- atForkInit = 1;
- }
-#endif /* HAVE_PTHREAD_ATFORK */
-
- notifierCount++;
- pthread_mutex_unlock(&notifierInitMutex);
-
+ (void)clientData;
#endif /* TCL_THREADS */
- return tsdPtr;
+#else /* !NOTIFIER_SELECT */
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+#if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD)
+ uint64_t eventFdVal = 1;
+
+ if (write(tsdPtr->triggerEventFd, &eventFdVal,
+ sizeof(eventFdVal)) != sizeof(eventFdVal)) {
+ Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd",
+ (void *) tsdPtr);
+ }
+#else
+ if (write(tsdPtr->triggerPipe[1], "", 1) != 1) {
+ Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerPipe",
+ (void *) tsdPtr);
}
+#endif /* NOTIFIER_EPOLL && HAVE_EVENTFD */
+#endif /* NOTIFIER_SELECT */
}
/*
*----------------------------------------------------------------------
*
- * Tcl_FinalizeNotifier --
+ * LookUpFileHandler --
*
- * This function is called to cleanup the notifier state before a thread
- * is terminated.
+ * Look up the file handler structure (and optionally the previous one in
+ * the chain) associated with a file descriptor.
*
- * Results:
- * None.
+ * Returns:
+ * A pointer to the file handler, or NULL if it can't be found.
*
* Side effects:
- * May terminate the background notifier thread if this is the last
- * notifier instance.
+ * If prevPtrPtr is non-NULL, it will be written to if the file handler
+ * is found.
*
*----------------------------------------------------------------------
*/
-void
-Tcl_FinalizeNotifier(
- void *clientData)
+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. */
{
- if (tclNotifierHooks.finalizeNotifierProc) {
- tclNotifierHooks.finalizeNotifierProc(clientData);
- return;
- } else {
-#ifdef TCL_THREADS
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- pthread_mutex_lock(&notifierInitMutex);
- notifierCount--;
-
- /*
- * If this is the last thread to use the notifier, close the notifier
- * pipe and wait for the background thread to terminate.
- */
+ FileHandler *filePtr, *prevPtr;
- if (notifierCount == 0 && triggerPipe != -1) {
- if (write(triggerPipe, "q", 1) != 1) {
- Tcl_Panic("Tcl_FinalizeNotifier: %s",
- "unable to write 'q' to triggerPipe");
- }
- close(triggerPipe);
- pthread_mutex_lock(&notifierMutex);
- while(triggerPipe != -1) {
- pthread_cond_wait(&notifierCV, &notifierMutex);
- }
- pthread_mutex_unlock(&notifierMutex);
- if (notifierThreadRunning) {
- int result = pthread_join((pthread_t) notifierThread, NULL);
+ /*
+ * Find the entry for the given file (and return if there isn't one).
+ */
- if (result) {
- Tcl_Panic("Tcl_FinalizeNotifier: %s",
- "unable to join notifier thread");
- }
- notifierThreadRunning = 0;
- }
+ for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
+ prevPtr = filePtr, filePtr = filePtr->nextPtr) {
+ if (filePtr == NULL) {
+ return NULL;
+ }
+ if (filePtr->fd == fd) {
+ break;
}
-
- /*
- * Clean up any synchronization objects in the thread local storage.
- */
-
-#ifdef __CYGWIN__
- DestroyWindow(tsdPtr->hwnd);
- CloseHandle(tsdPtr->event);
-#else /* __CYGWIN__ */
- pthread_cond_destroy(&tsdPtr->waitCV);
-#endif /* __CYGWIN__ */
- tsdPtr->waitCVinitialized = 0;
-
- pthread_mutex_unlock(&notifierInitMutex);
-#endif /* TCL_THREADS */
}
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 on a
- * given notifier after Tcl_FinalizeNotifier is called for that notifier.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Signals the notifier condition variable for the specified notifier.
- *
- *----------------------------------------------------------------------
- */
-void
-Tcl_AlertNotifier(
- void *clientData)
-{
- if (tclNotifierHooks.alertNotifierProc) {
- tclNotifierHooks.alertNotifierProc(clientData);
- return;
- } else {
-#ifdef TCL_THREADS
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
-
- pthread_mutex_lock(&notifierMutex);
- tsdPtr->eventReady = 1;
+ /*
+ * Report what we've found to our caller.
+ */
-# ifdef __CYGWIN__
- PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
-# else
- pthread_cond_broadcast(&tsdPtr->waitCV);
-# endif /* __CYGWIN__ */
- pthread_mutex_unlock(&notifierMutex);
-#endif /* TCL_THREADS */
+ if (prevPtrPtr) {
+ *prevPtrPtr = prevPtr;
}
+ return filePtr;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_SetTimer --
+ * TclpSetTimer --
*
* This function sets the current notifier timer value. This interface is
* not implemented in this notifier because we are always running inside
@@ -528,19 +212,14 @@ Tcl_AlertNotifier(
*/
void
-Tcl_SetTimer(
- const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
+TclpSetTimer(
+ TCL_UNUSED(const Tcl_Time *)) /* Timeout value, may be NULL. */
{
- if (tclNotifierHooks.setTimerProc) {
- tclNotifierHooks.setTimerProc(timePtr);
- return;
- } else {
- /*
- * The interval timer doesn't do anything in this implementation,
- * because the only event loop is via Tcl_DoOneEvent, which passes
- * timeout values to Tcl_WaitForEvent.
- */
- }
+ /*
+ * The interval timer doesn't do anything in this implementation, because
+ * the only event loop is via Tcl_DoOneEvent, which passes timeout values
+ * to Tcl_WaitForEvent.
+ */
}
/*
@@ -560,181 +239,16 @@ Tcl_SetTimer(
*/
void
-Tcl_ServiceModeHook(
+TclpServiceModeHook(
int mode) /* Either TCL_SERVICE_ALL, or
* TCL_SERVICE_NONE. */
{
- if (tclNotifierHooks.serviceModeHookProc) {
- tclNotifierHooks.serviceModeHookProc(mode);
- return;
- } else if (mode == TCL_SERVICE_ALL) {
+ if (mode == TCL_SERVICE_ALL) {
+#ifdef NOTIFIER_SELECT
#if TCL_THREADS
StartNotifierThread("Tcl_ServiceModeHook");
#endif
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateFileHandler --
- *
- * This function registers a file handler with the select notifier.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Creates a new file handler structure.
- *
- *----------------------------------------------------------------------
- */
-
-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. */
- void *clientData) /* Arbitrary data to pass to proc. */
-{
- if (tclNotifierHooks.createFileHandlerProc) {
- tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData);
- return;
- } else {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- FileHandler *filePtr;
-
- for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (filePtr->fd == fd) {
- break;
- }
- }
- if (filePtr == NULL) {
- filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
- filePtr->fd = fd;
- filePtr->readyMask = 0;
- filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
- tsdPtr->firstFileHandlerPtr = filePtr;
- }
- filePtr->proc = proc;
- filePtr->clientData = clientData;
- filePtr->mask = mask;
-
- /*
- * Update the check masks for this file.
- */
-
- if (mask & TCL_READABLE) {
- FD_SET(fd, &tsdPtr->checkMasks.readable);
- } else {
- FD_CLR(fd, &tsdPtr->checkMasks.readable);
- }
- if (mask & TCL_WRITABLE) {
- FD_SET(fd, &tsdPtr->checkMasks.writable);
- } else {
- FD_CLR(fd, &tsdPtr->checkMasks.writable);
- }
- if (mask & TCL_EXCEPTION) {
- FD_SET(fd, &tsdPtr->checkMasks.exception);
- } else {
- FD_CLR(fd, &tsdPtr->checkMasks.exception);
- }
- if (tsdPtr->numFdBits <= fd) {
- tsdPtr->numFdBits = fd+1;
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_DeleteFileHandler --
- *
- * Cancel a previously-arranged callback arrangement for a file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If a callback was previously registered on file, remove it.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_DeleteFileHandler(
- int fd) /* Stream id for which to remove callback
- * function. */
-{
- if (tclNotifierHooks.deleteFileHandlerProc) {
- tclNotifierHooks.deleteFileHandlerProc(fd);
- return;
- } else {
- FileHandler *filePtr, *prevPtr;
- int i;
- 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;
- }
- }
-
- /*
- * Update the check masks for this file.
- */
-
- if (filePtr->mask & TCL_READABLE) {
- FD_CLR(fd, &tsdPtr->checkMasks.readable);
- }
- if (filePtr->mask & TCL_WRITABLE) {
- FD_CLR(fd, &tsdPtr->checkMasks.writable);
- }
- if (filePtr->mask & TCL_EXCEPTION) {
- FD_CLR(fd, &tsdPtr->checkMasks.exception);
- }
-
- /*
- * Find current max fd.
- */
-
- if (fd+1 == tsdPtr->numFdBits) {
- int numFdBits = 0;
-
- 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.exception)) {
- numFdBits = i+1;
- break;
- }
- }
- tsdPtr->numFdBits = numFdBits;
- }
-
- /*
- * Clean up information in the callback record.
- */
-
- if (prevPtr == NULL) {
- tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
- } else {
- prevPtr->nextPtr = filePtr->nextPtr;
- }
- ckfree(filePtr);
+#endif /* NOTIFIER_SELECT */
}
}
@@ -812,576 +326,170 @@ FileHandlerEventProc(
return 1;
}
-#if defined(TCL_THREADS) && defined(__CYGWIN__)
-
-static unsigned int __stdcall
-NotifierProc(
- void *hwnd,
- unsigned int message,
- void *wParam,
- void *lParam)
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- if (message != 1024) {
- return DefWindowProcW(hwnd, message, wParam, lParam);
- }
-
- /*
- * Process all of the runnable events.
- */
-
- tsdPtr->eventReady = 1;
- Tcl_ServiceAll();
- return 0;
-}
-#endif /* TCL_THREADS && __CYGWIN__ */
-
+#ifdef NOTIFIER_SELECT
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
- * Tcl_WaitForEvent --
+ * AlertSingleThread --
*
- * 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
- * polls without blocking.
+ * Notify a single thread that is waiting on a file descriptor to become
+ * readable or writable or to have an exception condition.
+ * notifierMutex must be held.
*
- * Results:
- * Returns -1 if the select would block forever, otherwise returns 0.
+ * Result:
+ * None.
*
* Side effects:
- * Queues file events that are detected by the select.
+ * The condition variable associated with the thread is broadcasted.
*
*----------------------------------------------------------------------
*/
-int
-Tcl_WaitForEvent(
- const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+static void
+AlertSingleThread(
+ ThreadSpecificData *tsdPtr)
{
- if (tclNotifierHooks.waitForEventProc) {
- return tclNotifierHooks.waitForEventProc(timePtr);
- } else {
- FileHandler *filePtr;
- int mask;
- Tcl_Time vTime;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-#ifdef TCL_THREADS
- int waitForFiles;
-# ifdef __CYGWIN__
- MSG msg;
-# endif /* __CYGWIN__ */
-#else /* !TCL_THREADS */
- /*
- * Impl. notes: timeout & timeoutPtr are used if, and only if threads
- * are not enabled. They are the arguments for the regular select()
- * used when the core is not thread-enabled.
- */
-
- struct timeval timeout, *timeoutPtr;
- int numFound;
-#endif /* TCL_THREADS */
-
+ tsdPtr->eventReady = 1;
+ if (tsdPtr->onList) {
/*
- * Set up the timeout structure. Note that if there are no events to
- * check for, we return with a negative result rather than blocking
- * forever.
+ * Remove the ThreadSpecificData structure of this thread from the
+ * waiting list. This prevents us from continuously spinning on
+ * epoll_wait until the other threads runs and services the file
+ * event.
*/
- if (timePtr != NULL) {
- /*
- * TIP #233 (Virtualized Time). Is virtual time in effect? And do
- * we actually have something to scale? If yes to both then we
- * call the handler to do this scaling.
- */
-
- if (timePtr->sec != 0 || timePtr->usec != 0) {
- vTime = *timePtr;
- tclScaleTimeProcPtr(&vTime, tclTimeClientData);
- timePtr = &vTime;
- }
-#ifndef TCL_THREADS
- timeout.tv_sec = timePtr->sec;
- timeout.tv_usec = timePtr->usec;
- timeoutPtr = &timeout;
- } else if (tsdPtr->numFdBits == 0) {
- /*
- * If there are no threads, no timeout, and no fds registered,
- * then there are no events possible and we must avoid deadlock.
- * Note that this is not entirely correct because there might be a
- * signal that could interrupt the select call, but we don't
- * handle that case if we aren't using threads.
- */
-
- return -1;
+ if (tsdPtr->prevPtr) {
+ tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
- timeoutPtr = NULL;
-#endif /* !TCL_THREADS */
+ waitingListPtr = tsdPtr->nextPtr;
}
-
-#ifdef TCL_THREADS
- /*
- * Start notifier thread and place this thread on the list of
- * interested threads, signal the notifier thread, and wait for a
- * response or a timeout.
- */
- StartNotifierThread("Tcl_WaitForEvent");
-
- pthread_mutex_lock(&notifierMutex);
-
- if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0
-#if defined(__APPLE__) && defined(__LP64__)
- /*
- * 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. [Bug 1457797]
- */
- || timePtr->usec < 10
-#endif /* __APPLE__ && __LP64__ */
- )) {
- /*
- * Cannot emulate a polling select with a polling condition
- * variable. Instead, pretend to wait for files and tell the
- * notifier thread what we are doing. The notifier thread makes
- * sure it goes through select with its select mask in the same
- * state as ours currently is. We block until that happens.
- */
-
- waitForFiles = 1;
- tsdPtr->pollState = POLL_WANT;
- timePtr = NULL;
- } else {
- waitForFiles = (tsdPtr->numFdBits > 0);
- tsdPtr->pollState = 0;
+ if (tsdPtr->nextPtr) {
+ tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
-
- if (waitForFiles) {
- /*
- * Add the ThreadSpecificData structure of this thread to the list
- * of ThreadSpecificData structures of all threads that are
- * waiting on file events.
- */
-
- tsdPtr->nextPtr = waitingListPtr;
- if (waitingListPtr) {
- waitingListPtr->prevPtr = tsdPtr;
- }
- tsdPtr->prevPtr = 0;
- waitingListPtr = tsdPtr;
- tsdPtr->onList = 1;
-
- if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
- Tcl_Panic("Tcl_WaitForEvent: %s",
- "unable to write to triggerPipe");
- }
- }
-
- FD_ZERO(&tsdPtr->readyMasks.readable);
- FD_ZERO(&tsdPtr->readyMasks.writable);
- FD_ZERO(&tsdPtr->readyMasks.exception);
-
- if (!tsdPtr->eventReady) {
+ tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
+ tsdPtr->onList = 0;
+ tsdPtr->pollState = 0;
+ }
#ifdef __CYGWIN__
- if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
- unsigned int timeout;
-
- if (timePtr) {
- timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- } else {
- timeout = 0xFFFFFFFF;
- }
- pthread_mutex_unlock(&notifierMutex);
- MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
- pthread_mutex_lock(&notifierMutex);
- }
+ PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
#else /* !__CYGWIN__ */
- if (timePtr != NULL) {
- Tcl_Time now;
- struct timespec ptime;
-
- Tcl_GetTime(&now);
- ptime.tv_sec = timePtr->sec + now.sec +
- (timePtr->usec + now.usec) / 1000000;
- ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
-
- pthread_cond_timedwait(&tsdPtr->waitCV, &notifierMutex, &ptime);
- } else {
- pthread_cond_wait(&tsdPtr->waitCV, &notifierMutex);
- }
+ pthread_cond_broadcast(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */
- }
- tsdPtr->eventReady = 0;
-
-#ifdef __CYGWIN__
- while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
- /*
- * Retrieve and dispatch the message.
- */
-
- unsigned int result = GetMessageW(&msg, NULL, 0, 0);
-
- if (result == 0) {
- PostQuitMessage(msg.wParam);
- /* What to do here? */
- } else if (result != (unsigned int) -1) {
- TranslateMessage(&msg);
- DispatchMessageW(&msg);
- }
- }
- ResetEvent(tsdPtr->event);
-#endif /* __CYGWIN__ */
-
- if (waitForFiles && tsdPtr->onList) {
- /*
- * Remove the ThreadSpecificData structure of this thread from the
- * waiting list. Alert the notifier thread to recompute its select
- * masks - skipping this caused a hang when trying to close a pipe
- * which the notifier thread was still doing a select on.
- */
-
- if (tsdPtr->prevPtr) {
- tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
- } else {
- waitingListPtr = tsdPtr->nextPtr;
- }
- if (tsdPtr->nextPtr) {
- tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
- }
- tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
- tsdPtr->onList = 0;
- if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
- Tcl_Panic("Tcl_WaitForEvent: %s",
- "unable to write to triggerPipe");
- }
- }
-#else /* !TCL_THREADS */
- tsdPtr->readyMasks = tsdPtr->checkMasks;
- numFound = select(tsdPtr->numFdBits, &tsdPtr->readyMasks.readable,
- &tsdPtr->readyMasks.writable, &tsdPtr->readyMasks.exception,
- timeoutPtr);
-
- /*
- * Some systems don't clear the masks after an error, so we have to do
- * it here.
- */
-
- if (numFound == -1) {
- FD_ZERO(&tsdPtr->readyMasks.readable);
- FD_ZERO(&tsdPtr->readyMasks.writable);
- FD_ZERO(&tsdPtr->readyMasks.exception);
- }
-#endif /* TCL_THREADS */
-
- /*
- * Queue all detected file events before returning.
- */
-
- for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
- filePtr = filePtr->nextPtr) {
- mask = 0;
- if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.readable)) {
- mask |= TCL_READABLE;
- }
- if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.writable)) {
- mask |= TCL_WRITABLE;
- }
- if (FD_ISSET(filePtr->fd, &tsdPtr->readyMasks.exception)) {
- mask |= TCL_EXCEPTION;
- }
-
- if (!mask) {
- continue;
- }
-
- /*
- * Don't bother to queue an event if the mask was previously
- * non-zero since an event must still be on the queue.
- */
-
- if (filePtr->readyMask == 0) {
- FileHandlerEvent *fileEvPtr =
- (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
-
- fileEvPtr->header.proc = FileHandlerEventProc;
- fileEvPtr->fd = filePtr->fd;
- Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
- }
- filePtr->readyMask = mask;
- }
-#ifdef TCL_THREADS
- pthread_mutex_unlock(&notifierMutex);
-#endif /* TCL_THREADS */
- return 0;
- }
}
-#ifdef TCL_THREADS
+#if defined(HAVE_PTHREAD_ATFORK)
/*
*----------------------------------------------------------------------
*
- * NotifierThreadProc --
+ * AtForkChild --
*
- * This routine is the initial (and only) function executed by the
- * special notifier thread. Its job is to wait for file descriptors to
- * become readable or writable or to have an exception condition and then
- * to notify other threads who are interested in this information by
- * signalling a condition variable. Other threads can signal this
- * notifier thread of a change in their interests by writing a single
- * byte to a special pipe that the notifier thread is monitoring.
+ * Unlock and reinstall the notifier in the child after a fork.
*
- * Result:
- * None. Once started, this routine never exits. It dies with the overall
- * process.
+ * Results:
+ * None.
*
* Side effects:
- * The trigger pipe used to signal the notifier thread is created when
- * the notifier thread first starts.
+ * None.
*
*----------------------------------------------------------------------
*/
static void
-NotifierThreadProc(
- void *dummy) /* Not used. */
+AtForkChild(void)
{
- ThreadSpecificData *tsdPtr;
- fd_set readableMask;
- fd_set writableMask;
- fd_set exceptionMask;
- int i;
- int fds[2], receivePipe;
- long found;
- struct timeval poll = {0, 0}, *timePtr;
- char buf[2];
- int numFdBits = 0;
- (void)dummy;
-
- if (pipe(fds) != 0) {
- Tcl_Panic("NotifierThreadProc: %s", "could not create trigger pipe");
- }
-
- receivePipe = fds[0];
-
- if (TclUnixSetBlockingMode(receivePipe, TCL_MODE_NONBLOCKING) < 0) {
- Tcl_Panic("NotifierThreadProc: %s",
- "could not make receive pipe non blocking");
- }
- if (TclUnixSetBlockingMode(fds[1], TCL_MODE_NONBLOCKING) < 0) {
- Tcl_Panic("NotifierThreadProc: %s",
- "could not make trigger pipe non blocking");
- }
- if (fcntl(receivePipe, F_SETFD, FD_CLOEXEC) < 0) {
- Tcl_Panic("NotifierThreadProc: %s",
- "could not make receive pipe close-on-exec");
- }
- if (fcntl(fds[1], F_SETFD, FD_CLOEXEC) < 0) {
- Tcl_Panic("NotifierThreadProc: %s",
- "could not make trigger pipe close-on-exec");
+ if (notifierThreadRunning == 1) {
+ pthread_cond_destroy(&notifierCV);
}
+ pthread_mutex_init(&notifierInitMutex, NULL);
+ pthread_mutex_init(&notifierMutex, NULL);
+ pthread_cond_init(&notifierCV, NULL);
- /*
- * Install the write end of the pipe into the global variable.
- */
-
- pthread_mutex_lock(&notifierMutex);
- triggerPipe = fds[1];
-
- /*
- * Signal any threads that are waiting.
- */
-
- pthread_cond_broadcast(&notifierCV);
- pthread_mutex_unlock(&notifierMutex);
+#ifdef NOTIFIER_SELECT
+ asyncPending = 0;
+#endif
/*
- * Look for file events and report them to interested threads.
+ * notifierThreadRunning == 1: thread is running, (there might be data in
+ * notifier lists)
+ * atForkInit == 0: InitNotifier was never called
+ * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
+ * waitingListPtr != 0: there are threads currently waiting for events.
*/
- while (1) {
- FD_ZERO(&readableMask);
- FD_ZERO(&writableMask);
- FD_ZERO(&exceptionMask);
-
- /*
- * Compute the logical OR of the masks from all the waiting
- * notifiers.
- */
-
- pthread_mutex_lock(&notifierMutex);
- timePtr = NULL;
- for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
- for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
- if (FD_ISSET(i, &tsdPtr->checkMasks.readable)) {
- FD_SET(i, &readableMask);
- }
- if (FD_ISSET(i, &tsdPtr->checkMasks.writable)) {
- FD_SET(i, &writableMask);
- }
- if (FD_ISSET(i, &tsdPtr->checkMasks.exception)) {
- FD_SET(i, &exceptionMask);
- }
- }
- if (tsdPtr->numFdBits > numFdBits) {
- numFdBits = tsdPtr->numFdBits;
- }
- if (tsdPtr->pollState & POLL_WANT) {
- /*
- * Here we make sure we go through select() with the same mask
- * bits that were present when the thread tried to poll.
- */
-
- tsdPtr->pollState |= POLL_DONE;
- timePtr = &poll;
- }
- }
- pthread_mutex_unlock(&notifierMutex);
-
- /*
- * Set up the select mask to include the receive pipe.
- */
+ if (atForkInit == 1) {
- if (receivePipe >= numFdBits) {
- numFdBits = receivePipe + 1;
- }
- FD_SET(receivePipe, &readableMask);
+ notifierCount = 0;
+ if (notifierThreadRunning == 1) {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ notifierThreadRunning = 0;
- if (select(numFdBits, &readableMask, &writableMask, &exceptionMask,
- timePtr) == -1) {
+ close(triggerPipe);
+ triggerPipe = -1;
+#ifdef NOTIFIER_SELECT
+ close(otherPipe);
+ otherPipe = -1;
+#endif
/*
- * Try again immediately on an error.
+ * The waitingListPtr might contain event info from multiple
+ * threads, which are invalid here, so setting it to NULL is not
+ * unreasonable.
*/
+ waitingListPtr = NULL;
- continue;
- }
-
- /*
- * Alert any threads that are waiting on a ready file descriptor.
- */
-
- pthread_mutex_lock(&notifierMutex);
- for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
- found = 0;
-
- for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
- if (FD_ISSET(i, &tsdPtr->checkMasks.readable)
- && FD_ISSET(i, &readableMask)) {
- FD_SET(i, &tsdPtr->readyMasks.readable);
- found = 1;
- }
- if (FD_ISSET(i, &tsdPtr->checkMasks.writable)
- && FD_ISSET(i, &writableMask)) {
- FD_SET(i, &tsdPtr->readyMasks.writable);
- found = 1;
- }
- if (FD_ISSET(i, &tsdPtr->checkMasks.exception)
- && FD_ISSET(i, &exceptionMask)) {
- FD_SET(i, &tsdPtr->readyMasks.exception);
- found = 1;
- }
- }
-
- if (found || (tsdPtr->pollState & POLL_DONE)) {
- tsdPtr->eventReady = 1;
- if (tsdPtr->onList) {
- /*
- * Remove the ThreadSpecificData structure of this thread
- * from the waiting list. This prevents us from
- * continuously spining on select until the other threads
- * runs and services the file event.
- */
-
- if (tsdPtr->prevPtr) {
- tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
- } else {
- waitingListPtr = tsdPtr->nextPtr;
- }
- if (tsdPtr->nextPtr) {
- tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
- }
- tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
- tsdPtr->onList = 0;
- tsdPtr->pollState = 0;
- }
+ /*
+ * The tsdPtr from before the fork is copied as well. But since we
+ * are paranoiac, we don't trust its condvar and reset it.
+ */
#ifdef __CYGWIN__
- PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
-#else /* __CYGWIN__ */
- pthread_cond_broadcast(&tsdPtr->waitCV);
+ DestroyWindow(tsdPtr->hwnd);
+ tsdPtr->hwnd = CreateWindowExW(NULL, className,
+ className, 0, 0, 0, 0, 0, NULL, NULL,
+ TclWinGetTclInstance(), NULL);
+ ResetEvent(tsdPtr->event);
+#else /* !__CYGWIN__ */
+ pthread_cond_destroy(&tsdPtr->waitCV);
+ pthread_cond_init(&tsdPtr->waitCV, NULL);
#endif /* __CYGWIN__ */
- }
- }
- pthread_mutex_unlock(&notifierMutex);
-
- /*
- * Consume the next byte from the notifier pipe if the pipe was
- * readable. Note that there may be multiple bytes pending, but to
- * avoid a race condition we only read one at a time.
- */
- if (FD_ISSET(receivePipe, &readableMask)) {
- i = read(receivePipe, buf, 1);
-
- if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
- /*
- * Someone closed the write end of the pipe or sent us a Quit
- * message [Bug: 4139] and then closed the write end of the
- * pipe so we need to shut down the notifier thread.
- */
+ /*
+ * In case, we had multiple threads running before the fork,
+ * make sure, we don't try to reach out to their thread local data.
+ */
+ tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
- break;
- }
+ /*
+ * The list of registered event handlers at fork time is in
+ * tsdPtr->firstFileHandlerPtr;
+ */
}
}
+ Tcl_InitNotifier();
+
+#ifdef NOTIFIER_SELECT
/*
- * Clean up the read end of the pipe and signal any threads waiting on
- * termination of the notifier thread.
+ * Restart the notifier thread for signal handling.
*/
- close(receivePipe);
- pthread_mutex_lock(&notifierMutex);
- triggerPipe = -1;
- pthread_cond_broadcast(&notifierCV);
- pthread_mutex_unlock(&notifierMutex);
-
- TclpThreadExit(0);
-}
-
-#if defined(HAVE_PTHREAD_ATFORK)
-/*
- *----------------------------------------------------------------------
- *
- * AtForkPrepare --
- *
- * Lock the notifier in preparation for a fork.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AtForkPrepare(void)
-{
-#if RESET_ATFORK_MUTEX == 0
- pthread_mutex_lock(&notifierInitMutex);
+ StartNotifierThread("AtForkChild");
#endif
}
+#endif /* HAVE_PTHREAD_ATFORK */
+#endif /* TCL_THREADS */
+#endif /* NOTIFIER_SELECT */
/*
*----------------------------------------------------------------------
*
- * AtForkParent --
+ * TclpNotifierData --
*
- * Unlock the notifier in the parent after a fork.
+ * This function returns a ClientData pointer to be associated
+ * with a Tcl_AsyncHandler.
*
* Results:
- * None.
+ * For the epoll and kqueue notifiers, this function returns the
+ * thread specific data. Otherwise NULL.
*
* Side effects:
* None.
@@ -1389,100 +497,164 @@ AtForkPrepare(void)
*----------------------------------------------------------------------
*/
-static void
-AtForkParent(void)
+ClientData
+TclpNotifierData(void)
{
-#if RESET_ATFORK_MUTEX == 0
- pthread_mutex_unlock(&notifierInitMutex);
+#if defined(NOTIFIER_EPOLL) || defined(NOTIFIER_KQUEUE)
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ return (ClientData) tsdPtr;
+#else
+ return NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
- * AtForkChild --
+ * TclUnixWaitForFile --
*
- * Unlock and reinstall the notifier in the child after a fork.
+ * This function waits synchronously for a file to become readable or
+ * writable, with an optional timeout.
*
* Results:
- * None.
+ * The return value is an OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are
+ * present on file at the time of the return. This function will not
+ * return until either "timeout" milliseconds have elapsed or at least
+ * one of the conditions given by mask has occurred for file (a return
+ * value of 0 means that a timeout occurred). No normal events will be
+ * serviced during the execution of this function.
*
* Side effects:
- * None.
+ * Time passes.
*
*----------------------------------------------------------------------
*/
-static void
-AtForkChild(void)
+#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
+ * in tclMacOSXNotify.c */
+
+int
+TclUnixWaitForFile(
+ int fd, /* Handle for file on which to wait. */
+ int mask, /* What to wait for: OR'ed combination of
+ * TCL_READABLE, TCL_WRITABLE, and
+ * TCL_EXCEPTION. */
+ int timeout) /* Maximum amount of time to wait for one of
+ * the conditions in mask to occur, in
+ * milliseconds. A value of 0 means don't wait
+ * at all, and a value of -1 means wait
+ * forever. */
{
- if (notifierThreadRunning == 1) {
- pthread_cond_destroy(&notifierCV);
- }
-#if RESET_ATFORK_MUTEX == 0
- pthread_mutex_unlock(&notifierInitMutex);
-#else
- pthread_mutex_init(&notifierInitMutex, NULL);
- pthread_mutex_init(&notifierMutex, NULL);
-#endif
- pthread_cond_init(&notifierCV, NULL);
+ Tcl_Time abortTime = {0, 0}, now; /* silence gcc 4 warning */
+ struct timeval blockTime, *timeoutPtr;
+ struct pollfd pollFds[1];
+ int numFound, result = 0, pollTimeout;
/*
- * notifierThreadRunning == 1: thread is running, (there might be data in notifier lists)
- * atForkInit == 0: InitNotifier was never called
- * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
- * waitingListPtr != 0: there are threads currently waiting for events.
+ * If there is a non-zero finite timeout, compute the time when we give
+ * up.
*/
- if (atForkInit == 1) {
+ if (timeout > 0) {
+ Tcl_GetTime(&now);
+ abortTime.sec = now.sec + timeout / 1000;
+ abortTime.usec = now.usec + (timeout % 1000) * 1000;
+ if (abortTime.usec >= 1000000) {
+ abortTime.usec -= 1000000;
+ abortTime.sec += 1;
+ }
+ timeoutPtr = &blockTime;
+ } else if (timeout == 0) {
+ timeoutPtr = &blockTime;
+ blockTime.tv_sec = 0;
+ blockTime.tv_usec = 0;
+ } else {
+ timeoutPtr = NULL;
+ }
- notifierCount = 0;
- if (notifierThreadRunning == 1) {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- notifierThreadRunning = 0;
+ /*
+ * Setup the pollfd structure for the fd.
+ */
- close(triggerPipe);
- triggerPipe = -1;
- /*
- * The waitingListPtr might contain event info from multiple
- * threads, which are invalid here, so setting it to NULL is not
- * unreasonable.
- */
- waitingListPtr = NULL;
+ pollFds[0].fd = fd;
+ pollFds[0].events = pollFds[0].revents = 0;
+ if (mask & TCL_READABLE) {
+ pollFds[0].events |= (POLLIN | POLLHUP);
+ }
+ if (mask & TCL_WRITABLE) {
+ pollFds[0].events |= POLLOUT;
+ }
+ if (mask & TCL_EXCEPTION) {
+ pollFds[0].events |= POLLERR;
+ }
- /*
- * The tsdPtr from before the fork is copied as well. But since
- * we are paranoiac, we don't trust its condvar and reset it.
- */
-#ifdef __CYGWIN__
- DestroyWindow(tsdPtr->hwnd);
- tsdPtr->hwnd = CreateWindowExW(NULL, NotfyClassName,
- NotfyClassName, 0, 0, 0, 0, 0, NULL, NULL,
- TclWinGetTclInstance(), NULL);
- ResetEvent(tsdPtr->event);
-#else
- pthread_cond_destroy(&tsdPtr->waitCV);
- pthread_cond_init(&tsdPtr->waitCV, NULL);
-#endif
- /*
- * In case, we had multiple threads running before the fork,
- * make sure, we don't try to reach out to their thread local data.
- */
- tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
+ /*
+ * Loop in a mini-event loop of our own, waiting for either the file to
+ * become ready or a timeout to occur.
+ */
- /*
- * The list of registered event handlers at fork time is in
- * tsdPtr->firstFileHandlerPtr;
- */
+ do {
+ if (timeout > 0) {
+ blockTime.tv_sec = abortTime.sec - now.sec;
+ blockTime.tv_usec = abortTime.usec - now.usec;
+ if (blockTime.tv_usec < 0) {
+ blockTime.tv_sec -= 1;
+ blockTime.tv_usec += 1000000;
+ }
+ if (blockTime.tv_sec < 0) {
+ blockTime.tv_sec = 0;
+ blockTime.tv_usec = 0;
+ }
}
- }
- Tcl_InitNotifier();
-}
-#endif /* HAVE_PTHREAD_ATFORK */
+ /*
+ * Wait for the event or a timeout.
+ */
-#endif /* TCL_THREADS */
+ if (!timeoutPtr) {
+ pollTimeout = -1;
+ } else if (!timeoutPtr->tv_sec && !timeoutPtr->tv_usec) {
+ pollTimeout = 0;
+ } else {
+ pollTimeout = (int) timeoutPtr->tv_sec * 1000;
+ if (timeoutPtr->tv_usec) {
+ pollTimeout += (int) timeoutPtr->tv_usec / 1000;
+ }
+ }
+ numFound = poll(pollFds, 1, pollTimeout);
+ if (numFound == 1) {
+ result = 0;
+ if (pollFds[0].revents & (POLLIN | POLLHUP)) {
+ result |= TCL_READABLE;
+ }
+ if (pollFds[0].revents & POLLOUT) {
+ result |= TCL_WRITABLE;
+ }
+ if (pollFds[0].revents & POLLERR) {
+ result |= TCL_EXCEPTION;
+ }
+ if (result) {
+ break;
+ }
+ }
+ if (timeout == 0) {
+ break;
+ }
+ if (timeout < 0) {
+ continue;
+ }
+ /*
+ * The select returned early, so we need to recompute the timeout.
+ */
+
+ Tcl_GetTime(&now);
+ } while ((abortTime.sec > now.sec)
+ || (abortTime.sec == now.sec && abortTime.usec > now.usec));
+ return result;
+}
#endif /* !HAVE_COREFOUNDATION */
/*
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index 75e2879..b6ade1a 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -4,8 +4,8 @@
* This file implements the UNIX-specific exec pipeline functions, the
* "pipe" channel driver, and the "pid" Tcl command.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 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.
@@ -30,7 +30,7 @@
* This structure describes per-instance state of a pipe based channel.
*/
-typedef struct PipeState {
+typedef struct {
Tcl_Channel channel; /* Channel associated with this file. */
TclFile inFile; /* Output from pipe. */
TclFile outFile; /* Input to pipe. */
@@ -48,16 +48,16 @@ typedef struct PipeState {
* Declarations for local functions defined in this file:
*/
-static int PipeBlockModeProc(ClientData instanceData, int mode);
-static int PipeClose2Proc(ClientData instanceData,
+static int PipeBlockModeProc(void *instanceData, int mode);
+static int PipeClose2Proc(void *instanceData,
Tcl_Interp *interp, int flags);
-static int PipeGetHandleProc(ClientData instanceData,
- int direction, ClientData *handlePtr);
-static int PipeInputProc(ClientData instanceData, char *buf,
+static int PipeGetHandleProc(void *instanceData,
+ int direction, void **handlePtr);
+static int PipeInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
-static int PipeOutputProc(ClientData instanceData,
+static int PipeOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
-static void PipeWatchProc(ClientData instanceData, int mask);
+static void PipeWatchProc(void *instanceData, int mask);
static void RestoreSignals(void);
static int SetupStdFile(TclFile file, int type);
@@ -107,7 +107,7 @@ TclpMakeFile(
Tcl_Channel channel, /* Channel to get file from. */
int direction) /* Either TCL_READABLE or TCL_WRITABLE. */
{
- ClientData data;
+ void *data;
if (Tcl_GetChannelHandle(channel, direction, &data) != TCL_OK) {
return NULL;
@@ -141,7 +141,7 @@ TclpOpenFile(
const char *native;
Tcl_DString ds;
- native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
+ native = Tcl_UtfToExternalDString(NULL, fname, TCL_INDEX_NONE, &ds);
fd = TclOSopen(native, mode, 0666); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (fd != -1) {
@@ -153,7 +153,7 @@ TclpOpenFile(
*/
if ((mode & O_WRONLY) && !(mode & O_APPEND)) {
- TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
+ TclOSseek(fd, 0, SEEK_END);
}
/*
@@ -198,14 +198,14 @@ TclpCreateTempFile(
Tcl_DString dstring;
char *native;
- native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
+ native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring);
if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
- TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
+ TclOSseek(fd, 0, SEEK_SET);
}
return MakeFile(fd);
}
@@ -269,7 +269,7 @@ TclpTempFileName(void)
Tcl_Obj *
TclpTempFileNameForLibrary(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *path) /* Path name of the library in the VFS. */
+ TCL_UNUSED(Tcl_Obj *) /*path*/)
{
Tcl_Obj *retval = TclpTempFileName();
@@ -432,11 +432,11 @@ TclpCreateProcess(
* deallocated later
*/
- dsArray = TclStackAlloc(interp, argc * sizeof(Tcl_DString));
- newArgv = TclStackAlloc(interp, (argc+1) * sizeof(char *));
+ dsArray = (Tcl_DString *)TclStackAlloc(interp, argc * sizeof(Tcl_DString));
+ newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
- newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
+ newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], TCL_INDEX_NONE, &dsArray[i]);
}
#ifdef USE_VFORK
@@ -744,7 +744,7 @@ TclpCreateCommandChannel(
{
char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
- PipeState *statePtr = ckalloc(sizeof(PipeState));
+ PipeState *statePtr = (PipeState *)ckalloc(sizeof(PipeState));
int mode;
statePtr->inFile = readFile;
@@ -810,7 +810,7 @@ Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result. */
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
- int flags) /* Reserved for future use. */
+ TCL_UNUSED(int) /*flags*/) /* Reserved for future use. */
{
int fileNums[2];
@@ -869,10 +869,10 @@ TclGetAndDetachPids(
return;
}
- pipePtr = Tcl_GetChannelInstanceData(chan);
+ pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
- Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewIntObj(
+ Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewWideIntObj(
PTR2INT(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
@@ -902,12 +902,12 @@ TclGetAndDetachPids(
static int
PipeBlockModeProc(
- ClientData instanceData, /* Pipe state. */
+ void *instanceData, /* Pipe state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- PipeState *psPtr = instanceData;
+ PipeState *psPtr = (PipeState *)instanceData;
if (psPtr->inFile
&& TclUnixSetBlockingMode(GetFd(psPtr->inFile), mode) < 0) {
@@ -942,11 +942,11 @@ PipeBlockModeProc(
static int
PipeClose2Proc(
- ClientData instanceData, /* The pipe to close. */
+ void *instanceData, /* The pipe to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
- PipeState *pipePtr = instanceData;
+ PipeState *pipePtr = (PipeState *)instanceData;
Tcl_Channel errChan;
int errorCode, result;
@@ -1037,13 +1037,13 @@ PipeClose2Proc(
static int
PipeInputProc(
- ClientData instanceData, /* Pipe state. */
+ void *instanceData, /* Pipe state. */
char *buf, /* Where to store data read. */
int toRead, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
- PipeState *psPtr = instanceData;
+ PipeState *psPtr = (PipeState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
* input device? */
@@ -1088,12 +1088,12 @@ PipeInputProc(
static int
PipeOutputProc(
- ClientData instanceData, /* Pipe state. */
+ void *instanceData, /* Pipe state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
- PipeState *psPtr = instanceData;
+ PipeState *psPtr = (PipeState *)instanceData;
int written;
*errorCodePtr = 0;
@@ -1133,12 +1133,12 @@ PipeOutputProc(
static void
PipeWatchProc(
- ClientData instanceData, /* The pipe state. */
+ void *instanceData, /* The pipe state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
- PipeState *psPtr = instanceData;
+ PipeState *psPtr = (PipeState *)instanceData;
int newmask;
if (psPtr->inFile) {
@@ -1181,11 +1181,11 @@ PipeWatchProc(
static int
PipeGetHandleProc(
- ClientData instanceData, /* The pipe state. */
+ void *instanceData, /* The pipe state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr) /* Where to store the handle. */
+ void **handlePtr) /* Where to store the handle. */
{
- PipeState *psPtr = instanceData;
+ PipeState *psPtr = (PipeState *)instanceData;
if (direction == TCL_READABLE && psPtr->inFile) {
*handlePtr = INT2PTR(GetFd(psPtr->inFile));
@@ -1250,7 +1250,7 @@ Tcl_WaitPid(
int
Tcl_PidObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
@@ -1266,7 +1266,7 @@ Tcl_PidObjCmd(
}
if (objc == 1) {
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
} else {
/*
* Get the channel and make sure that it refers to a pipe.
@@ -1284,11 +1284,11 @@ Tcl_PidObjCmd(
* Extract the process IDs from the pipe structure.
*/
- pipePtr = Tcl_GetChannelInstanceData(chan);
+ pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
TclNewObj(resultPtr);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, resultPtr,
- Tcl_NewIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
+ Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
}
Tcl_SetObjResult(interp, resultPtr);
}
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 97caad0..5d5b14b 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -95,6 +95,8 @@ extern "C" {
# define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004
# define HANDLE void *
# define HINSTANCE void *
+# define HMODULE void *
+# define MAX_PATH 260
# define SOCKET unsigned int
# define WSAEWOULDBLOCK 10035
typedef unsigned short WCHAR;
@@ -118,15 +120,18 @@ extern "C" {
#pragma clang diagnostic pop
#endif
# define timezone _timezone
+ extern int TclOSfstat(int fd, void *statBuf);
extern int TclOSstat(const char *name, void *statBuf);
extern int TclOSlstat(const char *name, void *statBuf);
#ifdef __cplusplus
}
#endif
#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
+# define TclOSfstat(fd, buf) fstat64(fd, (struct stat64 *)buf)
# define TclOSstat(name, buf) stat64(name, (struct stat64 *)buf)
# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf)
#else
+# define TclOSfstat(fd, buf) fstat(fd, (struct stat *)buf)
# define TclOSstat(name, buf) stat(name, (struct stat *)buf)
# define TclOSlstat(name, buf) lstat(name, (struct stat *)buf)
#endif
@@ -142,16 +147,10 @@ extern "C" {
# include <sys/select.h>
#endif
#include <sys/stat.h>
-#ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
#ifdef HAVE_SYS_TIME_H
# include <sys/time.h>
-#else
-# include <time.h>
-#endif
#endif
+#include <time.h>
#ifndef NO_SYS_WAIT_H
# include <sys/wait.h>
#endif
@@ -161,14 +160,12 @@ extern "C" {
#include <limits.h>
#ifdef HAVE_STDINT_H
# include <stdint.h>
-#endif
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
#else
-# include "../compat/unistd.h"
+# include "../compat/stdint.h"
#endif
+#include <unistd.h>
-extern int TclUnixSetBlockingMode(int fd, int mode);
+MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode);
#include <utime.h>
@@ -198,13 +195,7 @@ extern int TclUnixSetBlockingMode(int fd, int mode);
*---------------------------------------------------------------------------
*/
-#ifndef NO_FLOAT_H
-# include <float.h>
-#else
-#ifndef NO_VALUES_H
-# include <values.h>
-#endif
-#endif
+#include <float.h>
#ifndef FLT_MAX
# ifdef MAXFLOAT
@@ -625,10 +616,8 @@ extern char ** environ;
# undef HAVE_COPYFILE
# endif
# if MAC_OS_X_VERSION_MAX_ALLOWED < 1030
-# ifdef TCL_THREADS
- /* prior to 10.3, realpath is not threadsafe, c.f. bug 711232 */
-# define NO_REALPATH 1
-# endif
+ /* prior to 10.3, realpath is not threadsafe, c.f. bug 711232 */
+# define NO_REALPATH 1
# undef HAVE_LANGINFO
# endif
# endif /* MAC_OS_X_VERSION_MAX_ALLOWED */
@@ -701,7 +690,7 @@ typedef int socklen_t;
#define TclpExit exit
-#ifdef TCL_THREADS
+#if !defined(TCL_THREADS) || TCL_THREADS
# include <pthread.h>
#endif /* TCL_THREADS */
@@ -721,14 +710,14 @@ typedef int socklen_t;
#include <pwd.h>
#include <grp.h>
-extern struct passwd * TclpGetPwNam(const char *name);
-extern struct group * TclpGetGrNam(const char *name);
-extern struct passwd * TclpGetPwUid(uid_t uid);
-extern struct group * TclpGetGrGid(gid_t gid);
-extern struct hostent * TclpGetHostByName(const char *name);
-extern struct hostent * TclpGetHostByAddr(const char *addr,
+MODULE_SCOPE struct passwd * TclpGetPwNam(const char *name);
+MODULE_SCOPE struct group * TclpGetGrNam(const char *name);
+MODULE_SCOPE struct passwd * TclpGetPwUid(uid_t uid);
+MODULE_SCOPE struct group * TclpGetGrGid(gid_t gid);
+MODULE_SCOPE struct hostent * TclpGetHostByName(const char *name);
+MODULE_SCOPE struct hostent * TclpGetHostByAddr(const char *addr,
int length, int type);
-extern void *TclpMakeTcpClientChannelMode(
+MODULE_SCOPE void *TclpMakeTcpClientChannelMode(
void *tcpSocket, int mode);
#endif /* _TCLUNIXPORT */
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 6ca1293..45a3c4d 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -3,13 +3,14 @@
*
* This file contains Unix-specific socket related code.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 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 <netinet/tcp.h>
/*
* Helper macros to make parts of this file clearer. The macros do exactly
@@ -23,7 +24,7 @@
/* "sock" + a pointer in hex + \0 */
#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1)
-#define SOCK_TEMPLATE "sock%lx"
+#define SOCK_TEMPLATE "sock%" TCL_Z_MODIFIER "x"
#undef SOCKET /* Possible conflict with win32 SOCKET */
@@ -53,9 +54,9 @@ typedef struct TcpFdList {
struct TcpState {
Tcl_Channel channel; /* Channel associated with this file. */
- TcpFdList fds; /* The file descriptors of the sockets. */
int flags; /* OR'ed combination of the bitfields defined
* below. */
+ TcpFdList fds; /* The file descriptors of the sockets. */
int interest; /* Event types of interest */
/*
@@ -93,6 +94,10 @@ struct TcpState {
* still pending */
#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */
+#define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not
+ * automatically continue connection
+ * process. */
+
/*
* The following defines the maximum length of the listen queue. This is the
* number of outstanding yet-to-be-serviced requests for a connection on a
@@ -135,6 +140,9 @@ static int TcpInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int TcpOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
+static int TcpSetOptionProc(void *instanceData,
+ Tcl_Interp *interp, const char *optionName,
+ const char *value);
static void TcpThreadActionProc(void *instanceData, int action);
static void TcpWatchProc(void *instanceData, int mask);
static int WaitForConnect(TcpState *statePtr, int *errorCodePtr);
@@ -148,11 +156,15 @@ static void WrapNotify(void *clientData, int mask);
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
+#ifndef TCL_NO_DEPRECATED
TcpCloseProc, /* Close proc. */
+#else
+ TCL_CLOSE2PROC, /* Close proc. */
+#endif
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
- NULL, /* Set option proc. */
+ TcpSetOptionProc, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
@@ -208,7 +220,7 @@ printaddrinfo(
static void
InitializeHostName(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *native = NULL;
@@ -244,9 +256,6 @@ InitializeHostName(
native = u.nodename;
}
}
- if (native == NULL) {
- native = tclEmptyStringRep;
- }
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
@@ -275,9 +284,15 @@ InitializeHostName(
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
- *lengthPtr = strlen(native);
- *valuePtr = (char *)ckalloc(*lengthPtr + 1);
- memcpy(*valuePtr, native, *lengthPtr + 1);
+ if (native) {
+ *lengthPtr = strlen(native);
+ *valuePtr = (char *)ckalloc(*lengthPtr + 1);
+ memcpy(*valuePtr, native, *lengthPtr + 1);
+ } else {
+ *lengthPtr = 0;
+ *valuePtr = (char *)ckalloc(1);
+ *valuePtr[0] = '\0';
+ }
}
/*
@@ -307,31 +322,6 @@ Tcl_GetHostName(void)
/*
* ----------------------------------------------------------------------
*
- * TclpHasSockets --
- *
- * Detect if sockets are available on this platform.
- *
- * Results:
- * Returns TCL_OK.
- *
- * Side effects:
- * None.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclpHasSockets(
- Tcl_Interp *dummy) /* Not used. */
-{
- (void)dummy;
-
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* TclpFinalizeSockets --
*
* Performs per-thread socket subsystem finalization.
@@ -448,6 +438,20 @@ WaitForConnect(
return 0;
}
+ /*
+ * In socket test mode do not continue with the connect.
+ * Exceptions are:
+ * - Call by recv/send and blocking socket
+ * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
+ */
+
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
+ && !(errorCodePtr != NULL
+ && !GOT_BITS(statePtr->flags, TCP_NONBLOCKING))) {
+ *errorCodePtr = EWOULDBLOCK;
+ return -1;
+ }
+
if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
timeout = 0;
} else {
@@ -564,7 +568,7 @@ TcpOutputProc(
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
- written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);
+ written = send(statePtr->fds.fd, buf, toWrite, 0);
if (written >= 0) {
return written;
@@ -594,12 +598,11 @@ TcpOutputProc(
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
- Tcl_Interp *dummy) /* For error reporting - unused. */
+ TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
int errorCode = 0;
TcpFdList *fds;
- (void)dummy;
/*
* Delete a file handler that may be active for this socket if this is a
@@ -656,13 +659,12 @@ TcpCloseProc(
static int
TcpClose2Proc(
void *instanceData, /* The socket to close. */
- Tcl_Interp *dummy, /* For error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
- (void)dummy;
/*
* Shutdown the OS socket handle.
@@ -787,6 +789,87 @@ TcpHostPortList(
/*
*----------------------------------------------------------------------
*
+ * TcpSetOptionProc --
+ *
+ * Sets TCP channel specific options.
+ *
+ * Results:
+ * None, unless an error happens.
+ *
+ * Side effects:
+ * Changes attributes of the socket at the system level.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TcpSetOptionProc(
+ void *instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For error reporting - can be NULL. */
+ const char *optionName, /* Name of the option to set. */
+ const char *value) /* New value for option. */
+{
+ TcpState *statePtr = (TcpState *)instanceData;
+ size_t len = 0;
+
+ if (optionName != NULL) {
+ len = strlen(optionName);
+ }
+
+ if ((len > 1) && (optionName[1] == 'k') &&
+ (strncmp(optionName, "-keepalive", len) == 0)) {
+ int val = 0, ret;
+
+ if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) {
+ return TCL_ERROR;
+ }
+#if defined(SO_KEEPALIVE)
+ ret = setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_KEEPALIVE,
+ (const char *) &val, sizeof(int));
+#else
+ ret = -1;
+ Tcl_SetErrno(ENOTSUP);
+#endif
+ if (ret < 0) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set socket option: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+ if ((len > 1) && (optionName[1] == 'n') &&
+ (strncmp(optionName, "-nodelay", len) == 0)) {
+ int val = 0, ret;
+
+ if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) {
+ return TCL_ERROR;
+ }
+#if defined(SOL_TCP) && defined(TCP_NODELAY)
+ ret = setsockopt(statePtr->fds.fd, SOL_TCP, TCP_NODELAY,
+ (const char *) &val, sizeof(int));
+#else
+ ret = -1;
+ Tcl_SetErrno(ENOTSUP);
+#endif
+ if (ret < 0) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set socket option: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+ return Tcl_BadChannelOption(interp, optionName, "keepalive nodelay");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TcpGetOptionProc --
*
* Computes an option value for a TCP socket based channel, or a list of
@@ -807,7 +890,7 @@ TcpHostPortList(
static int
TcpGetOptionProc(
- void *instanceData, /* Socket state. */
+ void *instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
@@ -818,8 +901,6 @@ TcpGetOptionProc(
TcpState *statePtr = (TcpState *)instanceData;
size_t len = 0;
- WaitForConnect(statePtr, NULL);
-
if (optionName != NULL) {
len = strlen(optionName);
}
@@ -828,6 +909,7 @@ TcpGetOptionProc(
(strncmp(optionName, "-error", len) == 0)) {
socklen_t optlen = sizeof(int);
+ WaitForConnect(statePtr, NULL);
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* Suppress errors as long as we are not done.
@@ -845,15 +927,16 @@ TcpGetOptionProc(
errno = err;
}
if (errno != 0) {
- Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1);
+ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE);
}
return TCL_OK;
}
if ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-connecting", len) == 0)) {
+ WaitForConnect(statePtr, NULL);
Tcl_DStringAppend(dsPtr,
- GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", -1);
+ GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE);
return TCL_OK;
}
@@ -862,6 +945,7 @@ TcpGetOptionProc(
address peername;
socklen_t size = sizeof(peername);
+ WaitForConnect(statePtr, NULL);
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* In async connect output an empty string
@@ -909,10 +993,11 @@ TcpGetOptionProc(
if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
(strncmp(optionName, "-sockname", len) == 0))) {
TcpFdList *fds;
- address sockname;
- socklen_t size;
+ address sockname;
+ socklen_t size;
int found = 0;
+ WaitForConnect(statePtr, NULL);
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sockname");
Tcl_DStringStartSublist(dsPtr);
@@ -946,9 +1031,49 @@ TcpGetOptionProc(
}
}
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'k') &&
+ (strncmp(optionName, "-keepalive", len) == 0))) {
+ int opt = 0;
+#if defined(SO_KEEPALIVE)
+ socklen_t size = sizeof(opt);
+#endif
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-keepalive");
+ }
+#if defined(SO_KEEPALIVE)
+ getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_KEEPALIVE,
+ (char *) &opt, &size);
+#endif
+ Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0");
+ if (len > 0) {
+ return TCL_OK;
+ }
+ }
+
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'n') &&
+ (strncmp(optionName, "-nodelay", len) == 0))) {
+ int opt = 0;
+#if defined(SOL_TCP) && defined(TCP_NODELAY)
+ socklen_t size = sizeof(opt);
+#endif
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-nodelay");
+ }
+#if defined(SOL_TCP) && defined(TCP_NODELAY)
+ getsockopt(statePtr->fds.fd, SOL_TCP, TCP_NODELAY,
+ (char *) &opt, &size);
+#endif
+ Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0");
+ if (len > 0) {
+ return TCL_OK;
+ }
+ }
+
if (len > 0) {
return Tcl_BadChannelOption(interp, optionName,
- "connecting peername sockname");
+ "connecting keepalive nodelay peername sockname");
}
return TCL_OK;
@@ -1121,11 +1246,10 @@ TcpWatchProc(
static int
TcpGetHandleProc(
void *instanceData, /* The socket state. */
- int direction, /* Not used. */
+ TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
- (void)direction;
*handlePtr = INT2PTR(statePtr->fds.fd);
return TCL_OK;
@@ -1146,12 +1270,8 @@ TcpGetHandleProc(
static void
TcpAsyncCallback(
void *clientData, /* The socket state. */
- int mask) /* Events of interest; an OR-ed combination of
- * TCL_READABLE, TCL_WRITABLE and
- * TCL_EXCEPTION. */
+ TCL_UNUSED(int) /*mask*/)
{
- (void)mask;
-
TcpConnect(NULL, (TcpState *)clientData);
}
@@ -1194,6 +1314,7 @@ TcpConnect(
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
int ret = -1, error = EHOSTUNREACH;
int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
+ static const int reuseaddr = 1;
if (async_callback) {
goto reenter;
@@ -1204,7 +1325,6 @@ TcpConnect(
for (statePtr->myaddr = statePtr->myaddrlist;
statePtr->myaddr != NULL;
statePtr->myaddr = statePtr->myaddr->ai_next) {
- int reuseaddr = 1;
/*
* No need to try combinations of local and remote addresses of
@@ -1428,7 +1548,7 @@ Tcl_OpenTcpClient(
return NULL;
}
- snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long)statePtr);
+ snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, TCL_READABLE | TCL_WRITABLE);
@@ -1495,7 +1615,7 @@ TclpMakeTcpClientChannelMode(
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
- snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long)statePtr);
+ snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, mode);
@@ -1510,7 +1630,7 @@ TclpMakeTcpClientChannelMode(
/*
*----------------------------------------------------------------------
*
- * Tcl_OpenTcpServer --
+ * Tcl_OpenTcpServerEx --
*
* Opens a TCP server socket and creates a channel around it.
*
@@ -1525,16 +1645,18 @@ TclpMakeTcpClientChannelMode(
*/
Tcl_Channel
-Tcl_OpenTcpServer(
+Tcl_OpenTcpServerEx(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
- int port, /* Port number to open. */
+ const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
+ unsigned int flags, /* Flags. */
+ int backlog, /* Length of OS listen backlog queue. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
void *acceptProcData) /* Data for the callback. */
{
- int status = 0, sock = -1, reuseaddr = 1, chosenport = 0;
+ int status = 0, sock = -1, optvalue, port, chosenport;
struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */
TcpState *statePtr = NULL;
char channelName[SOCK_CHAN_LENGTH];
@@ -1549,7 +1671,45 @@ Tcl_OpenTcpServer(
enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP;
int my_errno = 0;
- if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
+ /*
+ * If we were called with port 0 to listen on a random port number, we
+ * copy the port number from the first member of the addrinfo list to all
+ * subsequent members, so that IPv4 and IPv6 listen on the same port. This
+ * might fail to bind() with EADDRINUSE if a port is free on the first
+ * address family in the list but already used on the other. In this case
+ * we revert everything we've done so far and start from scratch hoping
+ * that next time we'll find a port number that is usable on all address
+ * families. We try this at most MAXRETRY times to avoid an endless loop
+ * if all ports are taken.
+ */
+
+ int retry = 0;
+#define MAXRETRY 10
+
+ repeat:
+ if (retry > 0) {
+ if (statePtr != NULL) {
+ TcpCloseProc(statePtr, NULL);
+ statePtr = NULL;
+ }
+ if (addrlist != NULL) {
+ freeaddrinfo(addrlist);
+ addrlist = NULL;
+ }
+ if (retry >= MAXRETRY) {
+ goto error;
+ }
+ }
+ retry++;
+ chosenport = 0;
+
+ if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
+ errorMsg = "invalid port number";
+ goto error;
+ }
+
+ if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
+ &errorMsg)) {
my_errno = errno;
goto error;
}
@@ -1579,12 +1739,30 @@ Tcl_OpenTcpServer(
TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE);
/*
- * Set up to reuse server addresses automatically and bind to the
- * specified port.
+ * Set up to reuse server addresses and/or ports if requested.
*/
- (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
- (char *) &reuseaddr, sizeof(reuseaddr));
+ if (GOT_BITS(flags, TCL_TCPSERVER_REUSEADDR)) {
+ optvalue = 1;
+ (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
+ (char *) &optvalue, sizeof(optvalue));
+ }
+
+ if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) {
+#ifndef SO_REUSEPORT
+ /*
+ * If the platform doesn't support the SO_REUSEPORT flag we can't
+ * do much beside erroring out.
+ */
+
+ errorMsg = "SO_REUSEPORT isn't supported by this platform";
+ goto error;
+#else
+ optvalue = 1;
+ (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT,
+ (char *) &optvalue, sizeof(optvalue));
+#endif
+ }
/*
* Make sure we use the same port number when opening two server
@@ -1620,6 +1798,9 @@ Tcl_OpenTcpServer(
}
close(sock);
sock = -1;
+ if (port == 0 && errno == EADDRINUSE) {
+ goto repeat;
+ }
continue;
}
if (port == 0 && chosenport == 0) {
@@ -1635,7 +1816,10 @@ Tcl_OpenTcpServer(
chosenport = ntohs(sockname.sa4.sin_port);
}
}
- status = listen(sock, SOMAXCONN);
+ if (backlog < 0) {
+ backlog = SOMAXCONN;
+ }
+ status = listen(sock, backlog);
if (status < 0) {
if (howfar < LISTEN) {
howfar = LISTEN;
@@ -1643,6 +1827,9 @@ Tcl_OpenTcpServer(
}
close(sock);
sock = -1;
+ if (port == 0 && errno == EADDRINUSE) {
+ goto repeat;
+ }
continue;
}
if (statePtr == NULL) {
@@ -1654,7 +1841,7 @@ Tcl_OpenTcpServer(
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
- snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long) statePtr);
+ snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr));
newfds = &statePtr->fds;
} else {
newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList));
@@ -1683,13 +1870,13 @@ Tcl_OpenTcpServer(
return statePtr->channel;
}
if (interp != NULL) {
- Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1);
+ Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE);
if (errorMsg == NULL) {
errno = my_errno;
- Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1);
+ Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE);
} else {
- Tcl_AppendToObj(errorObj, errorMsg, -1);
+ Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE);
}
Tcl_SetObjResult(interp, errorObj);
}
@@ -1718,7 +1905,7 @@ Tcl_OpenTcpServer(
static void
TcpAccept(
void *data, /* Callback token. */
- int mask) /* Not used. */
+ TCL_UNUSED(int) /*mask*/)
{
TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */
int newsock; /* The new client socket */
@@ -1727,7 +1914,6 @@ TcpAccept(
socklen_t len; /* For accept interface */
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
- (void)mask;
len = sizeof(addr);
newsock = accept(fds->fd, &addr.sa, &len);
@@ -1747,7 +1933,7 @@ TcpAccept(
newSockState->flags = 0;
newSockState->fds.fd = newsock;
- snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long)newSockState);
+ snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(newSockState));
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, TCL_READABLE | TCL_WRITABLE);
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index 92ea830..ee1229b 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -3,8 +3,8 @@
*
* Contains platform specific test commands for the Unix platform.
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1996-1997 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.
@@ -37,7 +37,7 @@
* exercised by the "testfilehandler" command.
*/
-typedef struct Pipe {
+typedef struct {
TclFile readFile; /* File handle for reading from the pipe. NULL
* means pipe doesn't exist yet. */
TclFile writeFile; /* File handle for writing from the pipe. */
@@ -62,16 +62,13 @@ static const char *gotsig = "0";
* Forward declarations of functions defined later in this file:
*/
-static Tcl_CmdProc TestalarmCmd;
+static Tcl_ObjCmdProc TestalarmCmd;
static Tcl_ObjCmdProc TestchmodCmd;
-static Tcl_CmdProc TestfilehandlerCmd;
-static Tcl_CmdProc TestfilewaitCmd;
-static Tcl_CmdProc TestfindexecutableCmd;
-static Tcl_ObjCmdProc TestforkObjCmd;
-static Tcl_CmdProc TestgetdefencdirCmd;
-static Tcl_CmdProc TestgetopenfileCmd;
-static Tcl_CmdProc TestgotsigCmd;
-static Tcl_CmdProc TestsetdefencdirCmd;
+static Tcl_ObjCmdProc TestfilehandlerCmd;
+static Tcl_ObjCmdProc TestfilewaitCmd;
+static Tcl_ObjCmdProc TestfindexecutableCmd;
+static Tcl_ObjCmdProc TestforkCmd;
+static Tcl_ObjCmdProc TestgotsigCmd;
static Tcl_FileProc TestFileHandlerProc;
static void AlarmHandler(int signum);
@@ -98,23 +95,17 @@ TclplatformtestInit(
{
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
+ Tcl_CreateObjCommand(interp, "testfilehandler", TestfilehandlerCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
+ Tcl_CreateObjCommand(interp, "testfilewait", TestfilewaitCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
+ Tcl_CreateObjCommand(interp, "testfindexecutable", TestfindexecutableCmd,
NULL, NULL);
- Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd,
+ Tcl_CreateObjCommand(interp, "testfork", TestforkCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
+ Tcl_CreateObjCommand(interp, "testalarm", TestalarmCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
- NULL, NULL);
- Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd,
- NULL, NULL);
- Tcl_CreateCommand(interp, "testalarm", TestalarmCmd,
- NULL, NULL);
- Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
+ Tcl_CreateObjCommand(interp, "testgotsig", TestgotsigCmd,
NULL, NULL);
return TCL_OK;
}
@@ -138,10 +129,10 @@ TclplatformtestInit(
static int
TestfilehandlerCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
@@ -161,24 +152,23 @@ TestfilehandlerCmd(
initialized = 1;
}
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " option ... \"", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
pipePtr = NULL;
- if (argc >= 3) {
- if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) {
+ if (objc >= 3) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &i) != TCL_OK) {
return TCL_ERROR;
}
if (i >= MAX_PIPES) {
- Tcl_AppendResult(interp, "bad index ", argv[2], NULL);
+ Tcl_AppendResult(interp, "bad index ", objv[2], NULL);
return TCL_ERROR;
}
pipePtr = &testPipes[i];
}
- if (strcmp(argv[1], "close") == 0) {
+ if (strcmp(Tcl_GetString(objv[1]), "close") == 0) {
for (i = 0; i < MAX_PIPES; i++) {
if (testPipes[i].readFile != NULL) {
TclpCloseFile(testPipes[i].readFile);
@@ -187,27 +177,24 @@ TestfilehandlerCmd(
testPipes[i].writeFile = NULL;
}
}
- } else if (strcmp(argv[1], "clear") == 0) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " clear index\"", NULL);
+ } else if (strcmp(Tcl_GetString(objv[1]), "clear") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
pipePtr->readCount = pipePtr->writeCount = 0;
- } else if (strcmp(argv[1], "counts") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[1]), "counts") == 0) {
char buf[TCL_INTEGER_SPACE * 2];
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " counts index\"", NULL);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
snprintf(buf, sizeof(buf), "%d %d", pipePtr->readCount, pipePtr->writeCount);
Tcl_AppendResult(interp, buf, NULL);
- } else if (strcmp(argv[1], "create") == 0) {
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " create index readMode writeMode\"", NULL);
+ } else if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index readMode writeMode");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
@@ -228,83 +215,79 @@ TestfilehandlerCmd(
pipePtr->readCount = 0;
pipePtr->writeCount = 0;
- if (strcmp(argv[3], "readable") == 0) {
+ if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
TestFileHandlerProc, pipePtr);
- } else if (strcmp(argv[3], "off") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[3]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
- } else if (strcmp(argv[3], "disabled") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[3]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
TestFileHandlerProc, pipePtr);
} else {
- Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", NULL);
+ Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
- if (strcmp(argv[4], "writable") == 0) {
+ if (strcmp(Tcl_GetString(objv[4]), "writable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
TestFileHandlerProc, pipePtr);
- } else if (strcmp(argv[4], "off") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[4]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
- } else if (strcmp(argv[4], "disabled") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[4]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
TestFileHandlerProc, pipePtr);
} else {
- Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", NULL);
+ Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[4]), "\"", NULL);
return TCL_ERROR;
}
- } else if (strcmp(argv[1], "empty") == 0) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " empty index\"", NULL);
+ } else if (strcmp(Tcl_GetString(objv[1]), "empty") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
- } else if (strcmp(argv[1], "fill") == 0) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " fill index\"", NULL);
+ } else if (strcmp(Tcl_GetString(objv[1]), "fill") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'a', 4000);
- while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
+ while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
/* Empty loop body. */
- }
- } else if (strcmp(argv[1], "fillpartial") == 0) {
+ }
+ } else if (strcmp(Tcl_GetString(objv[1]), "fillpartial") == 0) {
char buf[TCL_INTEGER_SPACE];
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " fillpartial index\"", NULL);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'b', 10);
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
Tcl_AppendResult(interp, buf, NULL);
- } else if (strcmp(argv[1], "oneevent") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[1]), "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
- } else if (strcmp(argv[1], "wait") == 0) {
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " wait index readable|writable timeout\"", NULL);
+ } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index readable|writable timeout");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
- Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist", NULL);
+ Tcl_AppendResult(interp, "pipe ", Tcl_GetString(objv[2]), " doesn't exist", NULL);
return TCL_ERROR;
}
- if (strcmp(argv[3], "readable") == 0) {
+ if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
mask = TCL_READABLE;
file = pipePtr->readFile;
} else {
mask = TCL_WRITABLE;
file = pipePtr->writeFile;
}
- if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[4], &timeout) != TCL_OK) {
return TCL_ERROR;
}
i = TclUnixWaitForFile(GetFd(file), mask, timeout);
@@ -314,10 +297,10 @@ TestfilehandlerCmd(
if (i & TCL_WRITABLE) {
Tcl_AppendElement(interp, "writable");
}
- } else if (strcmp(argv[1], "windowevent") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[1]), "windowevent") == 0) {
Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
+ Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be close, clear, counts, create, empty, fill, "
"fillpartial, oneevent, wait, or windowevent", NULL);
return TCL_ERROR;
@@ -331,7 +314,7 @@ TestFileHandlerProc(
int mask) /* Indicates which events happened:
* TCL_READABLE or TCL_WRITABLE. */
{
- Pipe *pipePtr = clientData;
+ Pipe *pipePtr = (Pipe *)clientData;
if (mask & TCL_READABLE) {
pipePtr->readCount++;
@@ -360,33 +343,32 @@ TestFileHandlerProc(
static int
TestfilewaitCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
ClientData data;
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " file readable|writable|both timeout\"", NULL);
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file readable|writable|both timeout");
return TCL_ERROR;
}
- channel = Tcl_GetChannel(interp, argv[1], NULL);
+ channel = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (channel == NULL) {
return TCL_ERROR;
}
- if (strcmp(argv[2], "readable") == 0) {
+ if (strcmp(Tcl_GetString(objv[2]), "readable") == 0) {
mask = TCL_READABLE;
- } else if (strcmp(argv[2], "writable") == 0){
+ } else if (strcmp(Tcl_GetString(objv[2]), "writable") == 0){
mask = TCL_WRITABLE;
- } else if (strcmp(argv[2], "both") == 0){
+ } else if (strcmp(Tcl_GetString(objv[2]), "both") == 0){
mask = TCL_WRITABLE|TCL_READABLE;
} else {
- Tcl_AppendResult(interp, "bad argument \"", argv[2],
+ Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
"\": must be readable, writable, or both", NULL);
return TCL_ERROR;
}
@@ -397,7 +379,7 @@ TestfilewaitCmd(
return TCL_ERROR;
}
fd = PTR2INT(data);
- if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
result = TclUnixWaitForFile(fd, mask, timeout);
@@ -429,23 +411,22 @@ TestfilewaitCmd(
static int
TestfindexecutableCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 strings. */
{
Tcl_Obj *saveName;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " argv0\"", NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "argv0");
return TCL_ERROR;
}
saveName = TclGetObjNameOfExecutable();
Tcl_IncrRefCount(saveName);
- TclpFindExecutable(argv[1]);
+ TclpFindExecutable(Tcl_GetString(objv[1]));
Tcl_SetObjResult(interp, TclGetObjNameOfExecutable());
TclSetObjNameOfExecutable(saveName, NULL);
@@ -456,84 +437,7 @@ TestfindexecutableCmd(
/*
*----------------------------------------------------------------------
*
- * TestgetopenfileCmd --
- *
- * This function implements the "testgetopenfile" command. It is used to
- * get a FILE * value from a registered channel.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestgetopenfileCmd(
- ClientData clientData, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
-{
- ClientData filePtr;
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName forWriting\"", NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
- == TCL_ERROR) {
- return TCL_ERROR;
- }
- if (filePtr == NULL) {
- Tcl_AppendResult(interp,
- "Tcl_GetOpenFile succeeded but FILE * NULL!", NULL);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestsetdefencdirCmd --
- *
- * This function implements the "testsetdefenc" command. It is used to
- * test Tcl_SetDefaultEncodingDir().
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestsetdefencdirCmd(
- ClientData clientData, /* Not used. */
- 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],
- " defaultDir\"", NULL);
- return TCL_ERROR;
- }
-
- Tcl_SetDefaultEncodingDir(argv[1]);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestforkObjCmd --
+ * TestforkCmd --
*
* This function implements the "testfork" command. It is used to
* fork the Tcl process for specific test cases.
@@ -548,11 +452,11 @@ TestsetdefencdirCmd(
*/
static int
-TestforkObjCmd(
- ClientData clientData, /* Not used. */
+TestforkCmd(
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* Argument strings. */
+ Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
@@ -571,40 +475,7 @@ TestforkObjCmd(
if (pid==0) {
Tcl_InitNotifier();
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(pid));
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestgetdefencdirCmd --
- *
- * This function implements the "testgetdefenc" command. It is used to
- * test Tcl_GetDefaultEncodingDir().
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestgetdefencdirCmd(
- ClientData clientData, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
-{
- if (argc != 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], NULL);
- return TCL_ERROR;
- }
-
- Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), NULL);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
return TCL_OK;
}
@@ -628,19 +499,17 @@ TestgetdefencdirCmd(
static int
TestalarmCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 strings. */
{
#ifdef SA_RESTART
- unsigned int sec;
+ unsigned int sec = 1;
struct sigaction action;
- if (argc > 1) {
- Tcl_GetInt(interp, argv[1], (int *)&sec);
- } else {
- sec = 1;
+ if (objc > 1) {
+ Tcl_GetIntFromObj(interp, objv[1], (int *)&sec);
}
/*
@@ -659,6 +528,7 @@ TestalarmCmd(
(void) alarm(sec);
return TCL_OK;
#else
+
Tcl_AppendResult(interp,
"warning: sigaction SA_RESTART not support on this platform",
NULL);
@@ -684,7 +554,7 @@ TestalarmCmd(
static void
AlarmHandler(
- int signum)
+ TCL_UNUSED(int) /*signum*/)
{
gotsig = "1";
}
@@ -707,10 +577,10 @@ AlarmHandler(
static int
TestgotsigCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *))
{
Tcl_AppendResult(interp, gotsig, NULL);
gotsig = "0";
@@ -738,7 +608,7 @@ TestgotsigCmd(
static int
TestchmodCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
@@ -762,7 +632,7 @@ TestchmodCmd(
if (translated == NULL) {
return TCL_ERROR;
}
- if (chmod(translated, (unsigned) mode) != 0) {
+ if (chmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
NULL);
return TCL_ERROR;
diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c
index e4a3c68..0c32b0d 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -3,9 +3,9 @@
*
* This file implements the UNIX-specific thread support.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 2008 by George Peter Staplin
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 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.
@@ -13,13 +13,160 @@
#include "tclInt.h"
-#ifdef TCL_THREADS
+#if TCL_THREADS
+
+/*
+ * TIP #509. Ensures that Tcl's mutexes are reentrant.
+ *
+ *----------------------------------------------------------------------
+ *
+ * PMutexInit --
+ *
+ * Sets up the memory pointed to by its argument so that it contains the
+ * implementation of a recursive lock. Caller supplies the space.
+ *
+ *----------------------------------------------------------------------
+ *
+ * PMutexDestroy --
+ *
+ * Tears down the implementation of a recursive lock (but does not
+ * deallocate the space holding the lock).
+ *
+ *----------------------------------------------------------------------
+ *
+ * PMutexLock --
+ *
+ * Locks a recursive lock. (Similar to pthread_mutex_lock)
+ *
+ *----------------------------------------------------------------------
+ *
+ * PMutexUnlock --
+ *
+ * Unlocks a recursive lock. (Similar to pthread_mutex_unlock)
+ *
+ *----------------------------------------------------------------------
+ *
+ * PCondWait --
+ *
+ * Waits on a condition variable linked a recursive lock. (Similar to
+ * pthread_cond_wait)
+ *
+ *----------------------------------------------------------------------
+ *
+ * PCondTimedWait --
+ *
+ * Waits for a limited amount of time on a condition variable linked to a
+ * recursive lock. (Similar to pthread_cond_timedwait)
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifndef HAVE_DECL_PTHREAD_MUTEX_RECURSIVE
+#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE 0
+#endif
+
+#if HAVE_DECL_PTHREAD_MUTEX_RECURSIVE
+/*
+ * Pthread has native reentrant (AKA recursive) mutexes. Use them for
+ * Tcl_Mutex.
+ */
+
+typedef pthread_mutex_t PMutex;
+
+static void
+PMutexInit(
+ PMutex *pmutexPtr)
+{
+ pthread_mutexattr_t attr;
+
+ pthread_mutexattr_init(&attr);
+ pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
+ pthread_mutex_init(pmutexPtr, &attr);
+}
+
+#define PMutexDestroy pthread_mutex_destroy
+#define PMutexLock pthread_mutex_lock
+#define PMutexUnlock pthread_mutex_unlock
+#define PCondWait pthread_cond_wait
+#define PCondTimedWait pthread_cond_timedwait
+
+#else /* !HAVE_PTHREAD_MUTEX_RECURSIVE */
-typedef struct ThreadSpecificData {
+/*
+ * No native support for reentrant mutexes. Emulate them with regular mutexes
+ * and thread-local counters.
+ */
+
+typedef struct PMutex {
+ pthread_mutex_t mutex;
+ pthread_t thread;
+ int counter;
+} PMutex;
+
+static void
+PMutexInit(
+ PMutex *pmutexPtr)
+{
+ pthread_mutex_init(&pmutexPtr->mutex, NULL);
+ pmutexPtr->thread = 0;
+ pmutexPtr->counter = 0;
+}
+
+static void
+PMutexDestroy(
+ PMutex *pmutexPtr)
+{
+ pthread_mutex_destroy(&pmutexPtr->mutex);
+}
+
+static void
+PMutexLock(
+ PMutex *pmutexPtr)
+{
+ if (pmutexPtr->thread != pthread_self() || pmutexPtr->counter == 0) {
+ pthread_mutex_lock(&pmutexPtr->mutex);
+ pmutexPtr->thread = pthread_self();
+ pmutexPtr->counter = 0;
+ }
+ pmutexPtr->counter++;
+}
+
+static void
+PMutexUnlock(
+ PMutex *pmutexPtr)
+{
+ pmutexPtr->counter--;
+ if (pmutexPtr->counter == 0) {
+ pmutexPtr->thread = 0;
+ pthread_mutex_unlock(&pmutexPtr->mutex);
+ }
+}
+
+static void
+PCondWait(
+ pthread_cond_t *pcondPtr,
+ PMutex *pmutexPtr)
+{
+ pthread_cond_wait(pcondPtr, &pmutexPtr->mutex);
+}
+
+static void
+PCondTimedWait(
+ pthread_cond_t *pcondPtr,
+ PMutex *pmutexPtr,
+ struct timespec *ptime)
+{
+ pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime);
+}
+#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */
+
+#ifndef TCL_NO_DEPRECATED
+typedef struct {
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+#endif /* TCL_NO_DEPRECATED */
/*
* globalLock is used to serialize creation of mutexes, condition variables,
@@ -41,15 +188,15 @@ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;
* obvious reasons, cannot use any dynamically allocated storage.
*/
-static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER;
-static pthread_mutex_t *allocLockPtr = &allocLock;
-
-/*
- * These are for the critical sections inside this file.
- */
+static PMutex allocLock;
+static pthread_once_t allocLockInitOnce = PTHREAD_ONCE_INIT;
-#define GLOBAL_LOCK pthread_mutex_lock(&globalLock)
-#define GLOBAL_UNLOCK pthread_mutex_unlock(&globalLock)
+static void
+allocLockInit(void)
+{
+ PMutexInit(&allocLock);
+}
+static PMutex *allocLockPtr = &allocLock;
#endif /* TCL_THREADS */
@@ -79,7 +226,7 @@ TclpThreadCreate(
int flags) /* Flags controlling behaviour of the new
* thread. */
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_attr_t attr;
pthread_t theThread;
int result;
@@ -130,6 +277,11 @@ TclpThreadCreate(
pthread_attr_destroy(&attr);
return result;
#else
+ (void)idPtr;
+ (void)proc;
+ (void)clientData;
+ (void)stackSize;
+ (void)flags;
return TCL_ERROR;
#endif /* TCL_THREADS */
}
@@ -157,7 +309,7 @@ Tcl_JoinThread(
* thread we wait upon will be written into.
* May be NULL. */
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
int result;
unsigned long retcode, *retcodePtr = &retcode;
@@ -167,11 +319,13 @@ Tcl_JoinThread(
}
return (result == 0) ? TCL_OK : TCL_ERROR;
#else
+ (void)threadId;
+ (void)state;
+
return TCL_ERROR;
#endif
}
-#ifdef TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -192,9 +346,12 @@ void
TclpThreadExit(
int status)
{
+#if TCL_THREADS
pthread_exit(INT2PTR(status));
-}
+#else /* TCL_THREADS */
+ exit(status);
#endif /* TCL_THREADS */
+}
/*
*----------------------------------------------------------------------
@@ -215,7 +372,7 @@ TclpThreadExit(
Tcl_ThreadId
Tcl_GetCurrentThread(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
return (Tcl_ThreadId) pthread_self();
#else
return (Tcl_ThreadId) 0;
@@ -244,7 +401,7 @@ Tcl_GetCurrentThread(void)
void
TclpInitLock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_lock(&initLock);
#endif
}
@@ -270,7 +427,7 @@ TclpInitLock(void)
void
TclFinalizeLock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* You do not need to destroy mutexes that were created with the
* PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
@@ -301,7 +458,7 @@ TclFinalizeLock(void)
void
TclpInitUnlock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_unlock(&initLock);
#endif
}
@@ -330,7 +487,7 @@ TclpInitUnlock(void)
void
TclpGlobalLock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_lock(&globalLock);
#endif
}
@@ -355,7 +512,7 @@ TclpGlobalLock(void)
void
TclpGlobalUnlock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_unlock(&globalLock);
#endif
}
@@ -382,15 +539,17 @@ TclpGlobalUnlock(void)
Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
-#ifdef TCL_THREADS
- pthread_mutex_t **allocLockPtrPtr = &allocLockPtr;
+#if TCL_THREADS
+ PMutex **allocLockPtrPtr = &allocLockPtr;
+
+ pthread_once(&allocLockInitOnce, allocLockInit);
return (Tcl_Mutex *) allocLockPtrPtr;
#else
return NULL;
#endif
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
@@ -415,26 +574,26 @@ Tcl_GetAllocMutex(void)
void
Tcl_MutexLock(
- Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */
+ Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
- pthread_mutex_t *pmutexPtr;
+ PMutex *pmutexPtr;
if (*mutexPtr == NULL) {
- GLOBAL_LOCK;
+ pthread_mutex_lock(&globalLock);
if (*mutexPtr == NULL) {
/*
* Double inside global lock check to avoid a race condition.
*/
- pmutexPtr = (pthread_mutex_t *)ckalloc(sizeof(pthread_mutex_t));
- pthread_mutex_init(pmutexPtr, NULL);
- *mutexPtr = (Tcl_Mutex)pmutexPtr;
+ pmutexPtr = (PMutex *)ckalloc(sizeof(PMutex));
+ PMutexInit(pmutexPtr);
+ *mutexPtr = (Tcl_Mutex) pmutexPtr;
TclRememberMutex(mutexPtr);
}
- GLOBAL_UNLOCK;
+ pthread_mutex_unlock(&globalLock);
}
- pmutexPtr = *((pthread_mutex_t **)mutexPtr);
- pthread_mutex_lock(pmutexPtr);
+ pmutexPtr = *((PMutex **) mutexPtr);
+ PMutexLock(pmutexPtr);
}
/*
@@ -456,11 +615,11 @@ Tcl_MutexLock(
void
Tcl_MutexUnlock(
- Tcl_Mutex *mutexPtr) /* Really (pthread_mutex_t **) */
+ Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
- pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **) mutexPtr;
+ PMutex *pmutexPtr = *(PMutex **) mutexPtr;
- pthread_mutex_unlock(pmutexPtr);
+ PMutexUnlock(pmutexPtr);
}
/*
@@ -486,10 +645,10 @@ void
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
- pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **) mutexPtr;
+ PMutex *pmutexPtr = *(PMutex **) mutexPtr;
if (pmutexPtr != NULL) {
- pthread_mutex_destroy(pmutexPtr);
+ PMutexDestroy(pmutexPtr);
ckfree(pmutexPtr);
*mutexPtr = NULL;
}
@@ -520,15 +679,15 @@ TclpFinalizeMutex(
void
Tcl_ConditionWait(
Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */
- Tcl_Mutex *mutexPtr, /* Really (pthread_mutex_t **) */
+ Tcl_Mutex *mutexPtr, /* Really (PMutex **) */
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
pthread_cond_t *pcondPtr;
- pthread_mutex_t *pmutexPtr;
+ PMutex *pmutexPtr;
struct timespec ptime;
if (*condPtr == NULL) {
- GLOBAL_LOCK;
+ pthread_mutex_lock(&globalLock);
/*
* Double check inside mutex to avoid race, then initialize condition
@@ -541,12 +700,12 @@ Tcl_ConditionWait(
*condPtr = (Tcl_Condition) pcondPtr;
TclRememberCondition(condPtr);
}
- GLOBAL_UNLOCK;
+ pthread_mutex_unlock(&globalLock);
}
- pmutexPtr = *((pthread_mutex_t **)mutexPtr);
+ pmutexPtr = *((PMutex **)mutexPtr);
pcondPtr = *((pthread_cond_t **)condPtr);
if (timePtr == NULL) {
- pthread_cond_wait(pcondPtr, pmutexPtr);
+ PCondWait(pcondPtr, pmutexPtr);
} else {
Tcl_Time now;
@@ -559,7 +718,7 @@ Tcl_ConditionWait(
ptime.tv_sec = timePtr->sec + now.sec +
(timePtr->usec + now.usec) / 1000000;
ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
- pthread_cond_timedwait(pcondPtr, pmutexPtr, &ptime);
+ PCondTimedWait(pcondPtr, pmutexPtr, &ptime);
}
}
@@ -651,6 +810,7 @@ TclpFinalizeCondition(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DirEntry *
TclpReaddir(
TclDIR * dir)
@@ -663,7 +823,7 @@ char *
TclpInetNtoa(
struct in_addr addr)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
unsigned char *b = (unsigned char*) &addr.s_addr;
@@ -673,26 +833,26 @@ TclpInetNtoa(
return inet_ntoa(addr);
#endif
}
+#endif /* TCL_NO_DEPRECATED */
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
-static volatile int initialized = 0;
static pthread_key_t key;
typedef struct {
Tcl_Mutex tlock;
- pthread_mutex_t plock;
+ PMutex plock;
} AllocMutex;
Tcl_Mutex *
TclpNewAllocMutex(void)
{
AllocMutex *lockPtr;
- pthread_mutex_t *plockPtr;
+ PMutex *plockPtr;
lockPtr = (AllocMutex *)malloc(sizeof(AllocMutex));
if (lockPtr == NULL) {
@@ -700,7 +860,7 @@ TclpNewAllocMutex(void)
}
plockPtr = &lockPtr->plock;
lockPtr->tlock = (Tcl_Mutex) plockPtr;
- pthread_mutex_init(&lockPtr->plock, NULL);
+ PMutexInit(&lockPtr->plock);
return &lockPtr->tlock;
}
@@ -713,11 +873,17 @@ TclpFreeAllocMutex(
if (!lockPtr) {
return;
}
- pthread_mutex_destroy(&lockPtr->plock);
+ PMutexDestroy(&lockPtr->plock);
free(lockPtr);
}
void
+TclpInitAllocCache(void)
+{
+ pthread_key_create(&key, NULL);
+}
+
+void
TclpFreeAllocCache(
void *ptr)
{
@@ -730,28 +896,19 @@ TclpFreeAllocCache(
TclFreeAllocCache(ptr);
pthread_setspecific(key, NULL);
- } else if (initialized) {
+ } else {
/*
* Called by TclFinalizeThreadAlloc() during the process
* finalization initiated from Tcl_Finalize()
*/
pthread_key_delete(key);
- initialized = 0;
}
}
void *
TclpGetAllocCache(void)
{
- if (!initialized) {
- pthread_mutex_lock(allocLockPtr);
- if (!initialized) {
- pthread_key_create(&key, NULL);
- initialized = 1;
- }
- pthread_mutex_unlock(allocLockPtr);
- }
return pthread_getspecific(key);
}
diff --git a/unix/tclUnixThrd.h b/unix/tclUnixThrd.h
deleted file mode 100644
index f03b530..0000000
--- a/unix/tclUnixThrd.h
+++ /dev/null
@@ -1,19 +0,0 @@
-/*
- * tclUnixThrd.h --
- *
- * This header file defines things for thread support.
- *
- * 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.
- */
-
-#ifndef _TCLUNIXTHRD
-#define _TCLUNIXTHRD
-
-#ifdef TCL_THREADS
-
-
-#endif /* TCL_THREADS */
-#endif /* _TCLUNIXTHRD */
diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c
index 85a31e1..f242cf4 100644
--- a/unix/tclUnixTime.c
+++ b/unix/tclUnixTime.c
@@ -4,14 +4,13 @@
* Contains Unix specific versions of Tcl functions that obtain time
* values from the operating system.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright © 1995 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 <locale.h>
#if defined(TCL_WIDE_CLICKS) && defined(MAC_OSX_TCL)
#include <mach/mach_time.h>
#endif
@@ -22,8 +21,9 @@
* variable is the key to this buffer.
*/
+#ifndef TCL_NO_DEPRECATED
static Tcl_ThreadDataKey tmKey;
-typedef struct ThreadSpecificData {
+typedef struct {
struct tm gmtime_buf;
struct tm localtime_buf;
} ThreadSpecificData;
@@ -45,6 +45,8 @@ static char *lastTZ = NULL; /* Holds the last setting of the TZ
static void SetTZIfNecessary(void);
static void CleanupMemory(ClientData clientData);
+#endif /* TCL_NO_DEPRECATED */
+
static void NativeScaleTime(Tcl_Time *timebuf,
ClientData clientData);
static void NativeGetTime(Tcl_Time *timebuf,
@@ -56,7 +58,24 @@ static void NativeGetTime(Tcl_Time *timebuf,
Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
-ClientData tclTimeClientData = NULL;
+void *tclTimeClientData = NULL;
+
+/*
+ * Inlined version of Tcl_GetTime.
+ */
+
+static inline void
+GetTime(
+ Tcl_Time *timePtr)
+{
+ tclGetTimeProcPtr(timePtr, tclTimeClientData);
+}
+
+static inline int
+IsTimeNative(void)
+{
+ return tclGetTimeProcPtr == NativeGetTime;
+}
/*
*----------------------------------------------------------------------
@@ -98,13 +117,13 @@ TclpGetSeconds(void)
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
TclpGetMicroseconds(void)
{
Tcl_Time time;
- tclGetTimeProcPtr(&time, tclTimeClientData);
- return ((Tcl_WideInt)time.sec)*1000000 + time.usec;
+ GetTime(&time);
+ return ((long long) time.sec)*1000000 + time.usec;
}
/*
@@ -132,10 +151,10 @@ TclpGetClicks(void)
unsigned long now;
#ifdef NO_GETTOD
- if (tclGetTimeProcPtr != NativeGetTime) {
+ if (!IsTimeNative()) {
Tcl_Time time;
- tclGetTimeProcPtr(&time, tclTimeClientData);
+ GetTime(&time);
now = ((unsigned long)(time.sec)*1000000UL) + (unsigned long)(time.usec);
} else {
/*
@@ -145,12 +164,12 @@ TclpGetClicks(void)
now = (unsigned long) times(&dummy);
}
-#else
+#else /* !NO_GETTOD */
Tcl_Time time;
- tclGetTimeProcPtr(&time, tclTimeClientData);
+ GetTime(&time);
now = ((unsigned long)(time.sec)*1000000UL) + (unsigned long)(time.usec);
-#endif
+#endif /* NO_GETTOD */
return now;
}
@@ -175,22 +194,22 @@ TclpGetClicks(void)
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
TclpGetWideClicks(void)
{
- Tcl_WideInt now;
+ long long now;
- if (tclGetTimeProcPtr != NativeGetTime) {
+ if (!IsTimeNative()) {
Tcl_Time time;
- tclGetTimeProcPtr(&time, tclTimeClientData);
- now = ((Tcl_WideInt)time.sec)*1000000 + time.usec;
+ GetTime(&time);
+ now = ((long long) time.sec)*1000000 + time.usec;
} else {
#ifdef MAC_OSX_TCL
- now = (Tcl_WideInt) (mach_absolute_time() & INT64_MAX);
+ now = (long long) (mach_absolute_time() & INT64_MAX);
#else
#error Wide high-resolution clicks not implemented on this platform
-#endif
+#endif /* MAC_OSX_TCL */
}
return now;
@@ -215,11 +234,11 @@ TclpGetWideClicks(void)
double
TclpWideClicksToNanoseconds(
- Tcl_WideInt clicks)
+ long long clicks)
{
double nsec;
- if (tclGetTimeProcPtr != NativeGetTime) {
+ if (!IsTimeNative()) {
nsec = clicks * 1000;
} else {
#ifdef MAC_OSX_TCL
@@ -237,7 +256,7 @@ TclpWideClicksToNanoseconds(
}
#else
#error Wide high-resolution clicks not implemented on this platform
-#endif
+#endif /* MAC_OSX_TCL */
}
return nsec;
@@ -264,7 +283,7 @@ TclpWideClicksToNanoseconds(
double
TclpWideClickInMicrosec(void)
{
- if (tclGetTimeProcPtr != NativeGetTime) {
+ if (!IsTimeNative()) {
return 1.0;
} else {
#ifdef MAC_OSX_TCL
@@ -284,7 +303,7 @@ TclpWideClickInMicrosec(void)
}
#else
#error Wide high-resolution clicks not implemented on this platform
-#endif
+#endif /* MAC_OSX_TCL */
}
}
#endif /* TCL_WIDE_CLICKS */
@@ -313,7 +332,7 @@ void
Tcl_GetTime(
Tcl_Time *timePtr) /* Location to store time information. */
{
- tclGetTimeProcPtr(timePtr, tclTimeClientData);
+ GetTime(timePtr);
}
/*
@@ -334,6 +353,7 @@ Tcl_GetTime(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGetDate(
const time_t *time,
@@ -423,6 +443,7 @@ TclpLocaltime(
return &tsdPtr->localtime_buf;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -504,8 +525,8 @@ Tcl_QueryTimeProc(
static void
NativeScaleTime(
- Tcl_Time *timePtr,
- ClientData clientData)
+ TCL_UNUSED(Tcl_Time *),
+ TCL_UNUSED(ClientData))
{
/* Native scale is 1:1. Nothing is done */
}
@@ -530,7 +551,7 @@ NativeScaleTime(
static void
NativeGetTime(
Tcl_Time *timePtr,
- ClientData clientData)
+ TCL_UNUSED(ClientData))
{
struct timeval tv;
@@ -557,6 +578,7 @@ NativeGetTime(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static void
SetTZIfNecessary(void)
{
@@ -573,7 +595,7 @@ SetTZIfNecessary(void)
} else {
ckfree(lastTZ);
}
- lastTZ = ckalloc(strlen(newTZ) + 1);
+ lastTZ = (char *) ckalloc(strlen(newTZ) + 1);
strcpy(lastTZ, newTZ);
}
Tcl_MutexUnlock(&tmMutex);
@@ -598,10 +620,11 @@ SetTZIfNecessary(void)
static void
CleanupMemory(
- ClientData ignored)
+ TCL_UNUSED(ClientData))
{
ckfree(lastTZ);
}
+#endif /* TCL_NO_DEPRECATED */
/*
* Local Variables:
diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c
index bea092c..4388009 100644
--- a/unix/tclXtNotify.c
+++ b/unix/tclXtNotify.c
@@ -4,7 +4,7 @@
* This file contains the notifier driver implementation for the Xt
* intrinsics.
*
- * 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.
@@ -42,7 +42,7 @@ typedef struct FileHandler {
* handlers are ready to fire.
*/
-typedef struct FileHandlerEvent {
+typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
int fd; /* File descriptor that is ready. Used to find
@@ -132,7 +132,7 @@ TclSetAppContext(
* after initialization, so we panic.
*/
- Tcl_Panic("TclSetAppContext: multiple application contexts");
+ Tcl_Panic("TclSetAppContext: multiple application contexts");
}
} else {
/*
@@ -181,7 +181,13 @@ TclSetAppContext(
void
InitNotifier(void)
{
- Tcl_NotifierProcs np;
+ static const Tcl_NotifierProcs np =
+ SetTimer,
+ WaitForEvent,
+ CreateFileHandler,
+ DeleteFileHandler,
+ NULL, NULL, NULL, NULL
+ };
/*
* Only reinitialize if we are not in exit handling. The notifier can get
@@ -193,11 +199,6 @@ InitNotifier(void)
return;
}
- memset(&np, 0, sizeof(np));
- np.createFileHandlerProc = CreateFileHandler;
- np.deleteFileHandlerProc = DeleteFileHandler;
- np.setTimerProc = SetTimer;
- np.waitForEventProc = WaitForEvent;
Tcl_SetNotifier(&np);
/*
@@ -228,7 +229,7 @@ InitNotifier(void)
static void
NotifierExitHandler(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
@@ -301,7 +302,7 @@ SetTimer(
static void
TimerProc(
- XtPointer clientData, /* Not used. */
+ TCL_UNUSED(XtPointer),
XtIntervalId *id)
{
if (*id != notifier.currentTimeout) {
@@ -355,7 +356,7 @@ CreateFileHandler(
}
}
if (filePtr == NULL) {
- filePtr = ckalloc(sizeof(FileHandler));
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->read = 0;
filePtr->write = 0;
@@ -492,7 +493,7 @@ FileProc(
int *fd,
XtInputId *id)
{
- FileHandler *filePtr = (FileHandler *)clientData;
+ FileHandler *filePtr = (FileHandler *) clientData;
FileHandlerEvent *fileEvPtr;
int mask = 0;
@@ -521,7 +522,7 @@ FileProc(
*/
filePtr->readyMask |= mask;
- fileEvPtr = ckalloc(sizeof(FileHandlerEvent));
+ fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c
index 7eb1fdc..882f497 100644
--- a/unix/tclXtTest.c
+++ b/unix/tclXtTest.c
@@ -3,7 +3,7 @@
*
* Contains commands for Xt notifier specific tests on Unix.
*
- * 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.
@@ -77,7 +77,7 @@ Tclxttest_Init(
static int
TesteventloopCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh
index 2279542..a400b5b 100644
--- a/unix/tclooConfig.sh
+++ b/unix/tclooConfig.sh
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
-TCLOO_VERSION=1.1.0
+TCLOO_VERSION=1.3
diff --git a/win/Makefile.in b/win/Makefile.in
index 7b0f209..6c92749 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -70,9 +70,6 @@ MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3
# Directory in which to install manual entries for the built-in Tcl commands:
MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann
-# Libraries built with optimization switches have this additional extension
-TCL_DBGX = @TCL_DBGX@
-
# warning flags
CFLAGS_WARNING = @CFLAGS_WARNING@
@@ -85,7 +82,7 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
#CFLAGS = $(CFLAGS_DEBUG)
#CFLAGS = $(CFLAGS_OPTIMIZE)
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
-CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -D_ATL_XP_TARGETING=1 -D__USE_MINGW_ANSI_STDIO=0 -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
+CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0 -DMP_NO_STDINT
# To compile without backward compatibility and deprecated code uncomment the
# following
@@ -101,11 +98,13 @@ COMPILE_DEBUG_FLAGS =
SRC_DIR = @srcdir@
ROOT_DIR = @srcdir@/..
TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P)
+BUILD_DIR = @builddir@
GENERIC_DIR = $(TOP_DIR)/generic
WIN_DIR = $(TOP_DIR)/win
COMPAT_DIR = $(TOP_DIR)/compat
PKGS_DIR = $(TOP_DIR)/pkgs
ZLIB_DIR = $(COMPAT_DIR)/zlib
+MINIZIP_DIR = $(ZLIB_DIR)/contrib/minizip
TOMMATH_DIR = $(TOP_DIR)/libtommath
# Converts a POSIX path to a Windows native path.
@@ -124,6 +123,7 @@ INCLUDE_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(INCLUDE_INSTALL_DIR)')
MAN_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(MAN_INSTALL_DIR)')
ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P)
ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)')
+MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)')
TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)')
# Fully qualify library path so that `make test`
@@ -141,30 +141,35 @@ DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@
REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@
REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@
+TCL_ZIP_FILE = @TCL_ZIP_FILE@
+TCL_VFS_PATH = libtcl.vfs/tcl_library
+TCL_VFS_ROOT = libtcl.vfs
+
+
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX}
-REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
-REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${DLLSUFFIX}${LIBSUFFIX}
+REG_DLL_FILE = tclregistry$(REGVER)${DLLSUFFIX}
+REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX}
TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
- package ifneeded dde 1.4.4 [list load [file normalize ${DDE_DLL_FILE}] Dde];\
- package ifneeded registry 1.3.5 [list load [file normalize ${REG_DLL_FILE}] Registry]
-TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}]];\
+ package ifneeded dde 1.4.5 [list load [file normalize ${DDE_DLL_FILE}]];\
+ package ifneeded registry 1.3.7 [list load [file normalize ${REG_DLL_FILE}]]
+TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\
$(TEST_LOAD_PRMS)
ZLIB_DLL_FILE = zlib1.dll
+TOMMATH_DLL_FILE = libtommath.dll
-SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
+SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
WINE = @WINE@
CAT32 = cat32$(EXEEXT)
-MAN2TCL = man2tcl$(EXEEXT)
# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
# available *BEFORE* running make for the first time. Certain build targets
@@ -199,16 +204,56 @@ SHLIB_LD = @SHLIB_LD@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
-LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@')
+LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@') $(shell $(CYGPATH) '@TOMMATH_LIBS@')
RMDIR = rm -rf
MKDIR = mkdir -p
SHELL = @SHELL@
RM = rm -f
COPY = cp
-
-CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
--I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" -DTCL_TOMMATH \
+LN = ln
+
+###
+# Tip 430 - ZipFS Modifications
+###
+
+TCL_ZIP_FILE = @TCL_ZIP_FILE@
+TCL_VFS_PATH = libtcl.vfs/tcl_library
+TCL_VFS_ROOT = libtcl.vfs
+
+HOST_CC = @CC_FOR_BUILD@
+HOST_EXEEXT = @EXEEXT_FOR_BUILD@
+HOST_OBJEXT = @OBJEXT_FOR_BUILD@
+ZIPFS_BUILD = @ZIPFS_BUILD@
+NATIVE_ZIP = @ZIP_PROG@
+ZIP_PROG_OPTIONS = @ZIP_PROG_OPTIONS@
+ZIP_PROG_VFSSEARCH = @ZIP_PROG_VFSSEARCH@
+SHARED_BUILD = @SHARED_BUILD@
+INSTALL_MSGS = @INSTALL_MSGS@
+INSTALL_LIBRARIES = @INSTALL_LIBRARIES@
+
+# Minizip
+MINIZIP_OBJS = \
+ adler32.$(HOST_OBJEXT) \
+ compress.$(HOST_OBJEXT) \
+ crc32.$(HOST_OBJEXT) \
+ deflate.$(HOST_OBJEXT) \
+ infback.$(HOST_OBJEXT) \
+ inffast.$(HOST_OBJEXT) \
+ inflate.$(HOST_OBJEXT) \
+ inftrees.$(HOST_OBJEXT) \
+ ioapi.$(HOST_OBJEXT) \
+ iowin32.$(HOST_OBJEXT) \
+ trees.$(HOST_OBJEXT) \
+ uncompr.$(HOST_OBJEXT) \
+ zip.$(HOST_OBJEXT) \
+ zutil.$(HOST_OBJEXT) \
+ minizip.$(HOST_OBJEXT)
+
+ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
+
+CC_SWITCHES = -I"${BUILD_DIR}" -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
+-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
@@ -216,7 +261,7 @@ CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
STUB_CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
--I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" -DTCL_TOMMATH \
+-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS}
@@ -233,6 +278,7 @@ GENERIC_OBJS = \
regfree.$(OBJEXT) \
regerror.$(OBJEXT) \
tclAlloc.$(OBJEXT) \
+ tclArithSeries.$(OBJEXT) \
tclAssembly.$(OBJEXT) \
tclAsync.$(OBJEXT) \
tclBasic.$(OBJEXT) \
@@ -296,6 +342,7 @@ GENERIC_OBJS = \
tclPosixStr.$(OBJEXT) \
tclPreserve.$(OBJEXT) \
tclProc.$(OBJEXT) \
+ tclProcess.$(OBJEXT) \
tclRegexp.$(OBJEXT) \
tclResolve.$(OBJEXT) \
tclResult.$(OBJEXT) \
@@ -313,6 +360,7 @@ GENERIC_OBJS = \
tclUtf.$(OBJEXT) \
tclUtil.$(OBJEXT) \
tclVar.$(OBJEXT) \
+ tclZipfs.$(OBJEXT) \
tclZlib.$(OBJEXT)
TOMMATH_OBJS = \
@@ -335,12 +383,15 @@ TOMMATH_OBJS = \
bn_mp_div_3.${OBJEXT} \
bn_mp_exch.${OBJEXT} \
bn_mp_expt_u32.${OBJEXT} \
+ bn_mp_get_mag_u64.${OBJEXT} \
bn_mp_grow.${OBJEXT} \
bn_mp_init.${OBJEXT} \
bn_mp_init_copy.${OBJEXT} \
+ bn_mp_init_i64.${OBJEXT} \
bn_mp_init_multi.${OBJEXT} \
bn_mp_init_set.${OBJEXT} \
bn_mp_init_size.${OBJEXT} \
+ bn_mp_init_u64.${OBJEXT} \
bn_mp_lshd.${OBJEXT} \
bn_mp_mod.${OBJEXT} \
bn_mp_mod_2d.${OBJEXT} \
@@ -356,7 +407,8 @@ TOMMATH_OBJS = \
bn_mp_radix_smap.${OBJEXT} \
bn_mp_read_radix.${OBJEXT} \
bn_mp_rshd.${OBJEXT} \
- bn_mp_set.${OBJEXT} \
+ bn_mp_set_i64.${OBJEXT} \
+ bn_mp_set_u64.${OBJEXT} \
bn_mp_shrink.${OBJEXT} \
bn_mp_sqr.${OBJEXT} \
bn_mp_sqrt.${OBJEXT} \
@@ -406,7 +458,8 @@ REG_OBJS = tclWinReg.$(OBJEXT)
STUB_OBJS = \
tclStubLib.$(OBJEXT) \
tclTomMathStubLib.$(OBJEXT) \
- tclOOStubLib.$(OBJEXT)
+ tclOOStubLib.$(OBJEXT) \
+ tclWinPanic.$(OBJEXT)
TCLSH_OBJS = tclAppInit.$(OBJEXT)
@@ -423,7 +476,7 @@ ZLIB_OBJS = \
uncompr.$(OBJEXT) \
zutil.$(OBJEXT)
-TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} @ZLIB_OBJS@ $(TOMMATH_OBJS)
+TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} @ZLIB_OBJS@ @TOMMATH_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
@@ -460,7 +513,7 @@ tcltest.sh: tcltest.cmd
tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd
-binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH)
+binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE}
@@ -468,11 +521,35 @@ libraries:
doc:
-$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
+tclzipfile: ${TCL_ZIP_FILE}
+
+${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE}
+ @rm -rf ${TCL_VFS_ROOT}
+ @mkdir -p ${TCL_VFS_PATH}
+ @echo "creating ${TCL_VFS_PATH} (prepare compression)"
+ @( \
+ $(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
+ $(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
+ $(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde; \
+ $(COPY) ${REG_DLL_FILE} ${TCL_VFS_PATH}/registry; \
+ )
+ (zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
+ (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \
+ cd ${TCL_VFS_ROOT} && \
+ $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
+ echo "${TCL_ZIP_FILE} successful created with $$zip" && \
+ cd ..)
+
+$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) ${TCL_ZIP_FILE}
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest $(TCLSH).manifest
@VC_MANIFEST_EMBED_EXE@
+ @if test "${ZIPFS_BUILD}" = "2" ; then \
+ cat ${TCL_ZIP_FILE} >> ${TCLSH}; \
+ ${NATIVE_ZIP} -A ${TCLSH} \
+ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+ fi
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
@@ -483,20 +560,25 @@ $(CAT32): cat32.$(OBJEXT)
# The following targets are configured by autoconf to generate either a shared
# library or static library
-${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
+${TCL_STUB_LIB_FILE}: ${STUB_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_STUB_LIB_FILE}
- @MAKE_STUB_LIB@ ${STUB_OBJS}
+ @MAKE_STUB_LIB@ ${STUB_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
-${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES)
+${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ ${TCL_ZIP_FILE}
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TCL_DLL_FILE}.manifest
@VC_MANIFEST_EMBED_DLL@
+ @if test "${ZIPFS_BUILD}" = "1" ; then \
+ cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
+ ${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
+ || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
+ fi
-${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
+${TCL_LIB_FILE}: ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
- @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
+ @MAKE_LIB@ ${TCL_OBJS} tclWinPanic.$(OBJEXT) ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
@@ -530,6 +612,14 @@ ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
$(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
fi;
+# use pre-built libtommath.dll
+${TOMMATH_DLL_FILE}: ${TCL_STUB_LIB_FILE}
+ @if test "@TOMMATH_LIBS@set" != "${TOMMATH_DIR_NATIVE}/win32/tommath.libset" ; then \
+ $(COPY) $(TOMMATH_DIR)/win64/${TOMMATH_DLL_FILE} ${TOMMATH_DLL_FILE}; \
+ else \
+ $(COPY) $(TOMMATH_DIR)/win32/${TOMMATH_DLL_FILE} ${TOMMATH_DLL_FILE}; \
+ fi;
+
# Add the object extension to the implicit rules. By default .obj is not
# automatically added.
@@ -560,6 +650,12 @@ tclAppInit.${OBJEXT}: tclAppInit.c
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
+# TIP #430, ZipFS Support
+tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
+ $(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
+ $(ZLIB_INCLUDE) -I$(MINIZIP_DIR_NATIVE) @DEPARG@ $(CC_OBJNAME)
+
+
# TIP #59, embedding of configuration information into the binary library.
#
# Part of Tcl's configuration information are the paths where it was installed
@@ -581,11 +677,14 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
-DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \
+ -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
tclEvent.${OBJEXT}: tclEvent.c tclUuid.h
+tclTest.${OBJEXT}: tclTest.c tclUuid.h
+
$(TOP_DIR)/manifest.uuid:
printf "git-" >$(TOP_DIR)/manifest.uuid
(cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || \
@@ -610,6 +709,9 @@ tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c
tclOOStubLib.${OBJEXT}: tclOOStubLib.c
$(CC) -c $(CC_SWITCHES) @CFLAGS_NOLTO@ @DEPARG@ $(CC_OBJNAME)
+tclWinPanic.${OBJEXT}: tclWinPanic.c
+ $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME)
+
# Implicit rule for all object files that will end up in the Tcl library
%.${OBJEXT}: %.c
@@ -618,6 +720,59 @@ tclOOStubLib.${OBJEXT}: tclOOStubLib.c
.rc.$(RES):
$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
+
+
+#--------------------------------------------------------------------------
+# Minizip implementation
+#--------------------------------------------------------------------------
+adler32.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c
+
+compress.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/compress.c
+
+crc32.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c
+
+deflate.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c
+
+ioapi.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c
+
+iowin32.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/iowin32.c
+
+infback.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c
+
+inffast.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inffast.c
+
+inflate.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inflate.c
+
+inftrees.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/inftrees.c
+
+trees.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/trees.c
+
+uncompr.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/uncompr.c
+
+zip.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c
+
+zutil.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c
+
+minizip.$(HOST_OBJEXT):
+ $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c
+
+minizip${HOST_EXEEXT}: $(MINIZIP_OBJS)
+ $(HOST_CC) -o $@ $(MINIZIP_OBJS)
+
# The following target generates the file generic/tclDate.c from the yacc
# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is
# not available in all environments. The name of the .c file is different than
@@ -630,15 +785,15 @@ gendate:
--no-lines \
$(GENERIC_DIR)/tclGetDate.y
-# The following target generates the file generic/tclTomMath.h. It needs to be
-# run (and the results checked) after updating to a new release of libtommath.
-
-gentommath_h:
- $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \
- "$(TOMMATH_DIR_NATIVE)/tommath.h" \
- > "$(GENERIC_DIR_NATIVE)/tclTomMath.h"
+INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA)
+INSTALL_DOC_TARGETS = install-doc
+INSTALL_PACKAGE_TARGETS = install-packages
+INSTALL_DEV_TARGETS = install-headers
+INSTALL_EXTRA_TARGETS =
+INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \
+ $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
-install: all install-binaries install-libraries install-doc install-packages
+install: $(INSTALL_TARGETS)
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \
@@ -650,7 +805,7 @@ install-binaries: binaries
else true; \
fi; \
done;
- @for i in dde${DDEDOTVER} reg${REGDOTVER}; \
+ @for i in dde${DDEDOTVER} registry${REGDOTVER}; \
do \
if [ ! -d "$(LIB_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
@@ -658,7 +813,7 @@ install-binaries: binaries
else true; \
fi; \
done;
- @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH); \
+ @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TOMMATH_DLL_FILE) $(TCLSH); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
@@ -684,13 +839,13 @@ install-binaries: binaries
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo Installing $(REG_DLL_FILE); \
- $(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
- $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
- "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
+ $(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
+ $(COPY) $(ROOT_DIR)/library/registry/pkgIndex.tcl \
+ "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
- $(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
+ $(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
fi
install-libraries: libraries install-tzdata install-msgs
@@ -703,7 +858,7 @@ install-libraries: libraries install-tzdata install-msgs
else true; \
fi; \
done;
- @for i in http1.0 opt0.4 encoding; \
+ @for i in opt0.4 cookiejar0.2 encoding; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -711,7 +866,7 @@ install-libraries: libraries install-tzdata install-msgs
else true; \
fi; \
done;
- @for i in 8.4 8.4/platform 8.5 8.6; \
+ @for i in 8.4 8.4/platform 8.5 8.6 8.7; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
@@ -719,36 +874,25 @@ install-libraries: libraries install-tzdata install-msgs
else true; \
fi; \
done;
- @echo "Installing header files";
- @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \
- "$(GENERIC_DIR)/tclOO.h" "$(GENERIC_DIR)/tclOODecls.h" \
- "$(GENERIC_DIR)/tclPlatDecls.h" \
- "$(GENERIC_DIR)/tclTomMath.h" \
- "$(GENERIC_DIR)/tclTomMathDecls.h"; \
- do \
- $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \
- done;
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
- @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \
- do \
+ @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing library http1.0 directory";
- @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
- do \
- $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
+ @echo "Installing package cookiejar 0.2"
+ @for j in $(ROOT_DIR)/library/cookiejar/*.tcl \
+ $(ROOT_DIR)/library/cookiejar/*.gz; do \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
- @echo "Installing package http 2.9.8 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.8.tm";
- @echo "Installing library opt0.4 directory";
- @for j in $(ROOT_DIR)/library/opt/*.tcl; \
- do \
+ @echo "Installing package http 2.10b1 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm";
+ @echo "Installing package opt 0.4.7";
+ @for j in $(ROOT_DIR)/library/opt/*.tcl; do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
- @echo "Installing package msgcat 1.6.1 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm";
- @echo "Installing package tcltest 2.5.5 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm";
+ @echo "Installing package msgcat 1.7.1 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm";
+ @echo "Installing package tcltest 2.5.6 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm";
@echo "Installing package platform 1.0.19 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm";
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@@ -770,6 +914,27 @@ install-msgs:
install-doc: doc
+install-headers:
+ @for i in "$(INCLUDE_INSTALL_DIR)"; \
+ do \
+ if [ ! -d "$$i" ] ; then \
+ echo "Making directory $$i"; \
+ $(MKDIR) "$$i"; \
+ chmod 755 "$$i"; \
+ else true; \
+ fi; \
+ done;
+ @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/";
+ @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
+ $(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \
+ $(GENERIC_DIR)/tclPlatDecls.h \
+ $(GENERIC_DIR)/tclTomMath.h \
+ $(GENERIC_DIR)/tclTomMathDecls.h \
+ $(TOMMATH_DIR)/tommath.h ; \
+ do \
+ $(COPY) $$i "$(INCLUDE_INSTALL_DIR)"; \
+ done;
+
# Optional target to install private headers
install-private-headers: libraries
@for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \
@@ -797,19 +962,19 @@ test: test-tcl test-packages
test-tcl: tcltest
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
+ $(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "$(TEST_LOAD_FACILITIES)"
# Useful target to launch a built tclsh with the proper path,...
runtest: tcltest
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT)
+ $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT)
# This target can be used to run tclsh from the build directory via
# `make shell SCRIPT=foo.tcl`
shell: binaries
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLSH) $(SCRIPT)
+ $(WINE) ./$(TCLSH) $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: binaries
@@ -823,17 +988,18 @@ Makefile: $(SRC_DIR)/Makefile.in
./config.status
cleanhelp:
- $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
+ $(RM) *.hlp *.cnt *.GID
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
$(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest.sh
$(RM) *.pch *.ilk *.pdb *.zip
+ $(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT}
$(RMDIR) *.vfs
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
- tcl.hpj config.status.lineno tclsh.exe.manifest tclUuid.h
+ config.status.lineno tclsh.exe.manifest tclUuid.h
#
# Bundled package targets
@@ -852,7 +1018,7 @@ packages:
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; \
echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \
- $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \
+ $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared; ) \
fi ; \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \
@@ -962,5 +1128,6 @@ html-tk: $(TCLSH)
.PHONY: gdb depend cleanhelp clean distclean packages install-packages
.PHONY: test-packages clean-packages distclean-packages genstubs html
.PHONY: html-tcl html-tk
+.PHONY: tclzipfile
# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/win/README b/win/README
index 86e9e59..3cfcc15 100644
--- a/win/README
+++ b/win/README
@@ -1,4 +1,4 @@
-Tcl 8.6 for Windows
+Tcl 8.7 for Windows
1. Introduction
---------------
@@ -16,11 +16,11 @@ The information in this file is maintained on the web at:
In order to compile Tcl for Windows, you need the following:
- Tcl 8.6 Source Distribution (plus any patches)
+ Tcl 8.7 Source Distribution (plus any patches)
and
- Visual C++ 6 or newer
+ Visual Studio 2015 or newer
or
@@ -80,11 +80,13 @@ Use the Makefile "install" target to install Tcl. It will install it
according to the prefix options you provided in the correct directory
structure.
-Note that in order to run tclsh86.exe, you must ensure that tcl86.dll
-and zlib1.dll are on your path, in the system directory, or in the
-directory containing tclsh86.exe.
+Note that in order to run tclsh87.exe, you must ensure that tcl87.dll,
+libtommath.dll and zlib1.dll are on your path, in the system
+directory, or in the directory containing tclsh87.exe.
-Note: Tcl no longer provides support for Win32s.
+Note: Tcl no longer provides support for systems earlier than Windows 7.
+You will also need the Windows Universal C runtime (UCRT):
+ [https://support.microsoft.com/en-us/topic/update-for-universal-c-runtime-in-windows-c0514201-7fe6-95a3-b0a5-287930f3560c]
3. Test suite
-------------
diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat
index deb9e39..941f27e 100644..100755
--- a/win/buildall.vc.bat
+++ b/win/buildall.vc.bat
@@ -38,7 +38,9 @@ if defined WINDOWSSDKDIR (goto :startBuilding)
:: might not be correct. You should call it yourself prior to running
:: this batchfile.
::
-call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+set "VSCMD_START_DIR=%CD%"
+call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat"
if errorlevel 1 (goto no_vcvars)
:startBuilding
@@ -66,8 +68,8 @@ if errorlevel 1 goto error
:: Build the static core and shell.
::
-set OPTS=static,msvcrt
-if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt
+set OPTS=static
+if not %SYMBOLS%.==. set OPTS=symbols,static
nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1
if errorlevel 1 goto error
diff --git a/win/coffbase.txt b/win/coffbase.txt
deleted file mode 100644
index a0ea5cf..0000000
--- a/win/coffbase.txt
+++ /dev/null
@@ -1,43 +0,0 @@
-;
-; This file defines the virtual base addresses for the Dynamic Link Libraries
-; that are part of the Tcl system. The first token on a line is the key (or name
-; of the DLL) and the second token is the virtual base address, in hexadecimal.
-; The third token is the maximum size of the DLL image file, including symbols.
-;
-; Using a specified "preferred load address" should speed loading time by avoiding
-; relocations (NT supported only). It is assumed extension authors will contribute
-; their modules to this grand-master list. You can use the dumpbin utility with
-; the /headers option to get the "size of image" data (already in hex). If the
-; maximum size is too small a linker warning will occur. Modules can overlap when
-; they're mutually exclusive. This info is placed in the DLL's PE header by the
-; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option.
-
-tcl 0x10000000 0x00200000
-tcldde 0x10200000 0x00010000
-tclreg 0x10210000 0x00010000
-tk 0x10220000 0x00200000
-expect 0x10480000 0x00080000
-itcl 0x10500000 0x00080000
-itk 0x10580000 0x00080000
-bltlite 0x10600000 0x00080000
-blt 0x10680000 0x00080000
-iocpsock 0x10700000 0x00080000
-tls 0x10780000 0x00100000
-winico 0x10880000 0x00010000
-sample 0x108B0000 0x00010000
-tile 0x10900000 0x00080000
-memchan 0x109D0000 0x00010000
-tdom 0x109E0000 0x00080000
-tclvfs 0x10A70000 0x00010000
-tkvideo 0x10B00000 0x00010000
-tclsdl 0x10B20000 0x00080000
-vqtcl 0x10C00000 0x00010000
-tdbc 0x10C40000 0x00010000
-thread 0x10C80000 0x00020000
-nsf 0x10ca0000 0x00080000
-;
-; insert new packages here
-;
-snack 0x1E000000 0x00400000
-sound 0x1E400000 0x00400000
-snackogg 0x1E800000 0x00200000
diff --git a/win/configure b/win/configure
index 25bc18a..ba0007f 100755
--- a/win/configure
+++ b/win/configure
@@ -1,81 +1,479 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.59 for tcl 8.6.
+# Generated by GNU Autoconf 2.71 for tcl 8.7.
+#
+#
+# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation,
+# Inc.
+#
#
-# 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. ##
-## --------------------- ##
+## -------------------- ##
+## M4sh Initialization. ##
+## -------------------- ##
-# Be Bourne compatible
-if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+as_nop=:
+if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
+then :
emulate sh
NULLCMD=:
- # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # Pre-4.2 versions of Zsh do 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
+ setopt NO_GLOB_SUBST
+else $as_nop
+ case `(set -o) 2>/dev/null` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
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
+# Reset variables that may have inherited troublesome values from
+# the environment.
+
+# IFS needs to be set, to space, tab, and newline, in precisely that order.
+# (If _AS_PATH_WALK were called with IFS unset, it would have the
+# side effect of setting IFS to empty, thus disabling word splitting.)
+# Quoting is to prevent editors from complaining about space-tab.
+as_nl='
+'
+export as_nl
+IFS=" "" $as_nl"
+
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
+# Ensure predictable behavior from utilities with locale-dependent output.
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# We cannot yet rely on "unset" to work, but we need these variables
+# to be unset--not just set to an empty or harmless value--now, to
+# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
+# also avoids known problems related to "unset" and subshell syntax
+# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
+for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
+do eval test \${$as_var+y} \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
+
+# Ensure that fds 0, 1, and 2 are open.
+if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
+if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
+if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
+
+# The user is always right.
+if ${PATH_SEPARATOR+false} :; then
+ PATH_SEPARATOR=:
+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
+ PATH_SEPARATOR=';'
+ }
+fi
+
+
+# Find who we are. Look in the path if we contain no directory separator.
+as_myself=
+case $0 in #((
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
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
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ test -r "$as_dir$0" && as_myself=$as_dir$0 && break
+ done
+IFS=$as_save_IFS
+
+ ;;
+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
+ printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+
+# Use a proper internal environment variable to ensure we don't fall
+ # into an infinite loop, continuously re-executing ourselves.
+ if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
+ _as_can_reexec=no; export _as_can_reexec;
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
fi
+ # We don't want this to propagate to other subprocesses.
+ { _as_can_reexec=; unset _as_can_reexec;}
+if test "x$CONFIG_SHELL" = x; then
+ as_bourne_compatible="as_nop=:
+if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
+then :
+ emulate sh
+ NULLCMD=:
+ # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '\${1+\"\$@\"}'='\"\$@\"'
+ setopt NO_GLOB_SUBST
+else \$as_nop
+ case \`(set -o) 2>/dev/null\` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
+fi
+"
+ as_required="as_fn_return () { (exit \$1); }
+as_fn_success () { as_fn_return 0; }
+as_fn_failure () { as_fn_return 1; }
+as_fn_ret_success () { return 0; }
+as_fn_ret_failure () { return 1; }
+
+exitcode=0
+as_fn_success || { exitcode=1; echo as_fn_success failed.; }
+as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }
+as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }
+as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }
+if ( set x; as_fn_ret_success y && test x = \"\$1\" )
+then :
+
+else \$as_nop
+ exitcode=1; echo positional parameters were not saved.
+fi
+test x\$exitcode = x0 || exit 1
+blah=\$(echo \$(echo blah))
+test x\"\$blah\" = xblah || exit 1
+test -x / || exit 1"
+ as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
+ as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
+ eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
+ test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1
+test \$(( 1 + 1 )) = 2 || exit 1"
+ if (eval "$as_required") 2>/dev/null
+then :
+ as_have_required=yes
+else $as_nop
+ as_have_required=no
+fi
+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null
+then :
+
+else $as_nop
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+as_found=false
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ as_found=:
+ case $as_dir in #(
+ /*)
+ for as_base in sh bash ksh sh5; do
+ # Try only shells that exist, to save several forks.
+ as_shell=$as_dir$as_base
+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
+ as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null
+then :
+ CONFIG_SHELL=$as_shell as_have_required=yes
+ if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null
+then :
+ break 2
+fi
+fi
+ done;;
+ esac
+ as_found=false
done
+IFS=$as_save_IFS
+if $as_found
+then :
+
+else $as_nop
+ if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
+ as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null
+then :
+ CONFIG_SHELL=$SHELL as_have_required=yes
+fi
+fi
+
+
+ if test "x$CONFIG_SHELL" != x
+then :
+ export CONFIG_SHELL
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
+fi
+
+ if test x$as_have_required = xno
+then :
+ printf "%s\n" "$0: This script requires a shell more modern than all"
+ printf "%s\n" "$0: the shells that I found on your system."
+ if test ${ZSH_VERSION+y} ; then
+ printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should"
+ printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later."
+ else
+ printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system,
+$0: including any error possibly output before this
+$0: message. Then install a modern shell, or manually run
+$0: the script under such a shell if you do have one."
+ fi
+ exit 1
+fi
+fi
+fi
+SHELL=${CONFIG_SHELL-/bin/sh}
+export SHELL
+# Unset more variables known to interfere with behavior of common tools.
+CLICOLOR_FORCE= GREP_OPTIONS=
+unset CLICOLOR_FORCE GREP_OPTIONS
+
+## --------------------- ##
+## M4sh Shell Functions. ##
+## --------------------- ##
+# as_fn_unset VAR
+# ---------------
+# Portably unset VAR.
+as_fn_unset ()
+{
+ { eval $1=; unset $1;}
+}
+as_unset=as_fn_unset
+
+
+# as_fn_set_status STATUS
+# -----------------------
+# Set $? to STATUS, without forking.
+as_fn_set_status ()
+{
+ return $1
+} # as_fn_set_status
+
+# as_fn_exit STATUS
+# -----------------
+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
+as_fn_exit ()
+{
+ set +e
+ as_fn_set_status $1
+ exit $1
+} # as_fn_exit
+# as_fn_nop
+# ---------
+# Do nothing but, unlike ":", preserve the value of $?.
+as_fn_nop ()
+{
+ return $?
+}
+as_nop=as_fn_nop
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
+# as_fn_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
+
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || eval $as_mkdir_p || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
+
+
+} # as_fn_mkdir_p
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
+# as_fn_append VAR VALUE
+# ----------------------
+# Append the text in VALUE to the end of the definition contained in VAR. Take
+# advantage of any shell optimizations that allow amortized linear growth over
+# repeated appends, instead of the typical quadratic growth present in naive
+# implementations.
+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
+then :
+ eval 'as_fn_append ()
+ {
+ eval $1+=\$2
+ }'
+else $as_nop
+ as_fn_append ()
+ {
+ eval $1=\$$1\$2
+ }
+fi # as_fn_append
+
+# as_fn_arith ARG...
+# ------------------
+# Perform arithmetic evaluation on the ARGs, and store the result in the
+# global $as_val. Take advantage of shells that can avoid forks. The arguments
+# must be portable across $(()) and expr.
+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
+then :
+ eval 'as_fn_arith ()
+ {
+ as_val=$(( $* ))
+ }'
+else $as_nop
+ as_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+# as_fn_nop
+# ---------
+# Do nothing but, unlike ":", preserve the value of $?.
+as_fn_nop ()
+{
+ return $?
+}
+as_nop=as_fn_nop
+
+# as_fn_error STATUS ERROR [LINENO LOG_FD]
+# ----------------------------------------
+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
+# script with STATUS, using 1 if that was 0.
+as_fn_error ()
+{
+ as_status=$1; test $as_status -eq 0 && as_status=1
+ if test "$4"; then
+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ printf "%s\n" "$as_me: error: $2" >&2
+ as_fn_exit $as_status
+} # as_fn_error
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
-if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
-# Name of the executable.
-as_me=`$as_basename "$0" ||
+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'`
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" 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'
@@ -83,146 +481,102 @@ 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 |
+ as_lineno_1=$LINENO as_lineno_1a=$LINENO
+ as_lineno_2=$LINENO as_lineno_2a=$LINENO
+ eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&
+ test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {
+ # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-)
+ sed -n '
+ p
+ /[$]LINENO/=
+ ' <$as_myself |
sed '
+ s/[$]LINENO.*/&-/
+ t lineno
+ b
+ :lineno
N
- s,$,-,
- : loop
- s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3,
+ :loop
+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
- s,-$,,
- s,^['$as_cr_digits']*\n,,
+ s/-\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; }; }
+ chmod +x "$as_me.lineno" ||
+ { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
+ # If we had to re-execute with $CONFIG_SHELL, we're ensured to have
+ # already done that, so ensure we don't try to do so again and fall
+ # in an infinite loop. This has already happened in practice.
+ _as_can_reexec=no; export _as_can_reexec
# 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
+ # original and so on. Autoconf is especially sensitive 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= ;;
+# Determine whether it's possible to make 'echo' print without a newline.
+# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
+# for compatibility with existing Makefiles.
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in #(((((
+-n*)
+ case `echo 'xy\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ xy) ECHO_C='\c';;
+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
+ ECHO_T=' ';;
+ esac;;
+*)
+ ECHO_N='-n';;
esac
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
+# For backward compatibility with old third-party macros, we provide
+# the shell variables $as_echo and $as_echo_n. New code should use
+# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
+as_echo='printf %s\n'
+as_echo_n='printf %s'
+
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
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
+fi
+if (echo >conf$$.file) 2>/dev/null; then
+ if ln -s conf$$.file conf$$ 2>/dev/null; then
as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -pR'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -pR'
+ elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+ else
+ as_ln_s='cp -pR'
fi
-elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
-rm -f conf$$ conf$$.exe conf$$.file
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
- as_mkdir_p=:
+ as_mkdir_p='mkdir -p "$as_dir"'
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
-as_executable_p="test -f"
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# 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'"
@@ -231,90 +585,252 @@ as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
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
-
+test -n "$DJDIR" || exec 7<&0 </dev/null
+exec 6>&1
# Name of the host.
-# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
+# hostname on some systems (SVR3.2, old GNU/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_clean_files=
ac_config_libobj_dir=.
+LIBOBJS=
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='tcl'
PACKAGE_TARNAME='tcl'
-PACKAGE_VERSION='8.6'
-PACKAGE_STRING='tcl 8.6'
+PACKAGE_VERSION='8.7'
+PACKAGE_STRING='tcl 8.7'
PACKAGE_BUGREPORT=''
+PACKAGE_URL=''
ac_unique_file="../generic/tcl.h"
# Factoring default headers for most tests.
ac_includes_default="\
-#include <stdio.h>
-#if HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#endif
-#if HAVE_SYS_STAT_H
-# include <sys/stat.h>
+#include <stddef.h>
+#ifdef HAVE_STDIO_H
+# include <stdio.h>
#endif
-#if STDC_HEADERS
+#ifdef HAVE_STDLIB_H
# include <stdlib.h>
-# include <stddef.h>
-#else
-# if HAVE_STDLIB_H
-# include <stdlib.h>
-# endif
#endif
-#if HAVE_STRING_H
-# if !STDC_HEADERS && HAVE_MEMORY_H
-# include <memory.h>
-# endif
+#ifdef HAVE_STRING_H
# include <string.h>
#endif
-#if HAVE_STRINGS_H
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#endif
+#ifdef HAVE_STRINGS_H
# include <strings.h>
#endif
-#if HAVE_INTTYPES_H
-# include <inttypes.h>
-#else
-# if HAVE_STDINT_H
-# include <stdint.h>
-# endif
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
#endif
-#if HAVE_UNISTD_H
+#ifdef HAVE_SYS_STAT_H
+# include <sys/stat.h>
+#endif
+#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif"
-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 CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_NOLTO ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_CC_SEARCH_FLAGS TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS'
+ac_header_c_list=
+ac_subst_vars='LTLIBOBJS
+LIBOBJS
+RES
+RC_DEFINES
+RC_DEFINE
+RC_INCLUDE
+RC_TYPE
+RC_OUT
+TCL_REG_MINOR_VERSION
+TCL_REG_MAJOR_VERSION
+TCL_REG_VERSION
+TCL_DDE_MINOR_VERSION
+TCL_DDE_MAJOR_VERSION
+TCL_DDE_VERSION
+TCL_PACKAGE_PATH
+TCL_LIB_VERSIONS_OK
+TCL_EXP_FILE
+TCL_BUILD_EXP_FILE
+TCL_NEEDS_EXP_FILE
+TCL_LD_SEARCH_FLAGS
+TCL_CC_SEARCH_FLAGS
+TCL_BUILD_LIB_SPEC
+MAKE_EXE
+MAKE_DLL
+POST_MAKE_LIB
+MAKE_STUB_LIB
+MAKE_LIB
+LIBRARIES
+EXESUFFIX
+LIBSUFFIX
+LIBPREFIX
+DLLSUFFIX
+LIBS_GUI
+TCL_SHARED_BUILD
+SHLIB_SUFFIX
+SHLIB_CFLAGS
+SHLIB_LD_LIBS
+SHLIB_LD
+STLIB_LD
+LDFLAGS_WINDOW
+LDFLAGS_CONSOLE
+LDFLAGS_OPTIMIZE
+LDFLAGS_DEBUG
+CC_EXENAME
+CC_OBJNAME
+DEPARG
+EXTRA_CFLAGS
+CFG_TCL_EXPORT_FILE_SUFFIX
+CFG_TCL_UNSHARED_LIB_SUFFIX
+CFG_TCL_SHARED_LIB_SUFFIX
+TCL_BIN_DIR
+TCL_SRC_DIR
+TCL_DLL_FILE
+TCL_BUILD_STUB_LIB_PATH
+TCL_BUILD_STUB_LIB_SPEC
+TCL_INCLUDE_SPEC
+TCL_STUB_LIB_PATH
+TCL_STUB_LIB_SPEC
+TCL_STUB_LIB_FLAG
+TCL_STUB_LIB_FILE
+TCL_LIB_SPEC
+TCL_IMPORT_LIB_FLAG
+TCL_IMPORT_LIB_FILE
+TCL_STATIC_LIB_FLAG
+TCL_STATIC_LIB_FILE
+TCL_LIB_FLAG
+TCL_LIB_FILE
+TCL_EXE
+PKG_CFG_ARGS
+TCL_PATCH_LEVEL
+TCL_MINOR_VERSION
+TCL_MAJOR_VERSION
+TCL_VERSION
+MACHINE
+TCL_WIN_VERSION
+VC_MANIFEST_EMBED_EXE
+VC_MANIFEST_EMBED_DLL
+EGREP
+GREP
+CPP
+LDFLAGS_DEFAULT
+CFLAGS_DEFAULT
+INSTALL_MSGS
+INSTALL_LIBRARIES
+TCL_ZIP_FILE
+ZIPFS_BUILD
+ZIP_INSTALL_OBJS
+ZIP_PROG_VFSSEARCH
+ZIP_PROG_OPTIONS
+ZIP_PROG
+TCLSH_PROG
+EXEEXT_FOR_BUILD
+CC_FOR_BUILD
+TOMMATH_OBJS
+ZLIB_OBJS
+TOMMATH_LIBS
+ZLIB_LIBS
+TOMMATH_DLL_FILE
+ZLIB_DLL_FILE
+CFLAGS_NOLTO
+CFLAGS_WARNING
+CFLAGS_OPTIMIZE
+CFLAGS_DEBUG
+DL_LIBS
+WINE
+CYGPATH
+SHARED_BUILD
+SET_MAKE
+RC
+RANLIB
+AR
+OBJEXT
+EXEEXT
+ac_ct_CC
+CPPFLAGS
+LDFLAGS
+CFLAGS
+CC
+target_alias
+host_alias
+build_alias
+LIBS
+ECHO_T
+ECHO_N
+ECHO_C
+DEFS
+mandir
+localedir
+libdir
+psdir
+pdfdir
+dvidir
+htmldir
+infodir
+docdir
+oldincludedir
+includedir
+runstatedir
+localstatedir
+sharedstatedir
+sysconfdir
+datadir
+datarootdir
+libexecdir
+sbindir
+bindir
+program_transform_name
+prefix
+exec_prefix
+PACKAGE_URL
+PACKAGE_BUGREPORT
+PACKAGE_STRING
+PACKAGE_VERSION
+PACKAGE_TARNAME
+PACKAGE_NAME
+PATH_SEPARATOR
+SHELL
+OBJEXT_FOR_BUILD'
ac_subst_files=''
+ac_user_opts='
+enable_option_checking
+with_encoding
+enable_shared
+enable_time64bit
+enable_64bit
+enable_zipfs
+enable_symbols
+enable_embedded_manifest
+'
+ ac_precious_vars='build_alias
+host_alias
+target_alias
+CC
+CFLAGS
+LDFLAGS
+LIBS
+CPPFLAGS
+CPP'
+
# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
+ac_unrecognized_opts=
+ac_unrecognized_sep=
# The variables have the same names as the options, with
# dashes changed to underlines.
cache_file=/dev/null
@@ -337,34 +853,48 @@ x_libraries=NONE
# 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.
+# (The list follows the same order as the GNU Coding Standards.)
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
+datarootdir='${prefix}/share'
+datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
+runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
+docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
+infodir='${datarootdir}/info'
+htmldir='${docdir}'
+dvidir='${docdir}'
+pdfdir='${docdir}'
+psdir='${docdir}'
+libdir='${exec_prefix}/lib'
+localedir='${datarootdir}/locale'
+mandir='${datarootdir}/man'
ac_prev=
+ac_dashdash=
for ac_option
do
# If the previous option needs an argument, assign it.
if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
+ 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
+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *=) ac_optarg= ;;
+ *) ac_optarg=yes ;;
+ esac
+
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
@@ -386,33 +916,59 @@ do
--config-cache | -C)
cache_file=config.cache ;;
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
+ -datadir | --datadir | --datadi | --datad)
ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
+ -datadir=* | --datadir=* | --datadi=* | --datad=*)
datadir=$ac_optarg ;;
+ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
+ | --dataroo | --dataro | --datar)
+ ac_prev=datarootdir ;;
+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
+ datarootdir=$ac_optarg ;;
+
-disable-* | --disable-*)
- ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
+ ac_useropt=`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" ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid feature name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"enable_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval enable_$ac_useropt=no ;;
+
+ -docdir | --docdir | --docdi | --doc | --do)
+ ac_prev=docdir ;;
+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
+ docdir=$ac_optarg ;;
+
+ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
+ ac_prev=dvidir ;;
+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
+ dvidir=$ac_optarg ;;
-enable-* | --enable-*)
- ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
+ ac_useropt=`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 ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid feature name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"enable_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
esac
- eval "enable_$ac_feature='$ac_optarg'" ;;
+ eval enable_$ac_useropt=\$ac_optarg ;;
-exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
| --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
@@ -439,6 +995,12 @@ do
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
+ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
+ ac_prev=htmldir ;;
+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
+ | --ht=*)
+ htmldir=$ac_optarg ;;
+
-includedir | --includedir | --includedi | --included | --include \
| --includ | --inclu | --incl | --inc)
ac_prev=includedir ;;
@@ -463,13 +1025,16 @@ do
| --libexe=* | --libex=* | --libe=*)
libexecdir=$ac_optarg ;;
+ -localedir | --localedir | --localedi | --localed | --locale)
+ ac_prev=localedir ;;
+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
+ localedir=$ac_optarg ;;
+
-localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
+ | --localstate | --localstat | --localsta | --localst | --locals)
ac_prev=localstatedir ;;
-localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
localstatedir=$ac_optarg ;;
-mandir | --mandir | --mandi | --mand | --man | --ma | --m)
@@ -534,10 +1099,29 @@ do
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
+ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
+ ac_prev=pdfdir ;;
+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
+ pdfdir=$ac_optarg ;;
+
+ -psdir | --psdir | --psdi | --psd | --ps)
+ ac_prev=psdir ;;
+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
+ psdir=$ac_optarg ;;
+
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
+ -runstatedir | --runstatedir | --runstatedi | --runstated \
+ | --runstate | --runstat | --runsta | --runst | --runs \
+ | --run | --ru | --r)
+ ac_prev=runstatedir ;;
+ -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
+ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
+ | --run=* | --ru=* | --r=*)
+ runstatedir=$ac_optarg ;;
+
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
@@ -584,26 +1168,36 @@ do
ac_init_version=: ;;
-with-* | --with-*)
- ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
+ ac_useropt=`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 ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid package name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"with_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
esac
- eval "with_$ac_package='$ac_optarg'" ;;
+ eval with_$ac_useropt=\$ac_optarg ;;
-without-* | --without-*)
- ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
+ ac_useropt=`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" ;;
+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
+ as_fn_error $? "invalid package name: \`$ac_useropt'"
+ ac_useropt_orig=$ac_useropt
+ ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
+ case $ac_user_opts in
+ *"
+"with_$ac_useropt"
+"*) ;;
+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"
+ ac_unrecognized_sep=', ';;
+ esac
+ eval with_$ac_useropt=no ;;
--x)
# Obsolete; use --with-x.
@@ -623,27 +1217,26 @@ do
| --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; }; }
+ -*) as_fn_error $? "unrecognized option: \`$ac_option'
+Try \`$0 --help' for more information"
;;
*=*)
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'"
+ case $ac_envvar in #(
+ '' | [0-9]* | *[!_$as_cr_alnum]* )
+ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
+ esac
+ 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
+ printf "%s\n" "$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}
+ printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
@@ -651,31 +1244,36 @@ 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; }; }
+ as_fn_error $? "missing argument to $ac_option"
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; }; };;
+if test -n "$ac_unrecognized_opts"; then
+ case $enable_option_checking in
+ no) ;;
+ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;
+ *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;
esac
-done
+fi
-# Be sure to have absolute paths.
-for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
- localstatedir libdir includedir oldincludedir infodir mandir
+# Check all directory arguments for consistency.
+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
+ datadir sysconfdir sharedstatedir localstatedir includedir \
+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
+ libdir localedir mandir runstatedir
do
- eval ac_val=$`echo $ac_var`
+ eval ac_val=\$$ac_var
+ # Remove trailing slashes.
case $ac_val in
- [\\/$]* | ?:[\\/]* ) ;;
- *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
- { (exit 1); exit 1; }; };;
+ */ )
+ ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`
+ eval $ac_var=\$ac_val;;
esac
+ # Be sure to have absolute directory names.
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* ) continue;;
+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
+ esac
+ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"
done
# There might be people who depend on the old broken behavior: `$host'
@@ -689,8 +1287,6 @@ target=$target_alias
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
@@ -702,74 +1298,72 @@ test -n "$host_alias" && ac_tool_prefix=$host_alias-
test "$silent" = yes && exec 6>/dev/null
+ac_pwd=`pwd` && test -n "$ac_pwd" &&
+ac_ls_di=`ls -di .` &&
+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
+ as_fn_error $? "working directory cannot be determined"
+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
+ as_fn_error $? "pwd does not report name of working directory"
+
+
# 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'`
+ # Try the directory containing this script, then the parent directory.
+ ac_confdir=`$as_dirname -- "$as_myself" ||
+$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_myself" : 'X\(//\)[^/]' \| \
+ X"$as_myself" : 'X\(//\)$' \| \
+ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$as_myself" |
+ 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
+ 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
-ac_env_CC_set=${CC+set}
-ac_env_CC_value=$CC
-ac_cv_env_CC_set=${CC+set}
-ac_cv_env_CC_value=$CC
-ac_env_CFLAGS_set=${CFLAGS+set}
-ac_env_CFLAGS_value=$CFLAGS
-ac_cv_env_CFLAGS_set=${CFLAGS+set}
-ac_cv_env_CFLAGS_value=$CFLAGS
-ac_env_LDFLAGS_set=${LDFLAGS+set}
-ac_env_LDFLAGS_value=$LDFLAGS
-ac_cv_env_LDFLAGS_set=${LDFLAGS+set}
-ac_cv_env_LDFLAGS_value=$LDFLAGS
-ac_env_CPPFLAGS_set=${CPPFLAGS+set}
-ac_env_CPPFLAGS_value=$CPPFLAGS
-ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set}
-ac_cv_env_CPPFLAGS_value=$CPPFLAGS
-ac_env_CPP_set=${CPP+set}
-ac_env_CPP_value=$CPP
-ac_cv_env_CPP_set=${CPP+set}
-ac_cv_env_CPP_value=$CPP
+if test ! -r "$srcdir/$ac_unique_file"; then
+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
+ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"
+fi
+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
+ac_abs_confdir=`(
+ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"
+ pwd)`
+# When building in place, set srcdir=.
+if test "$ac_abs_confdir" = "$ac_pwd"; then
+ srcdir=.
+fi
+# Remove unnecessary trailing slashes from srcdir.
+# Double slashes in file names in object file debugging info
+# mess up M-x gdb in Emacs.
+case $srcdir in
+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
+esac
+for ac_var in $ac_precious_vars; do
+ eval ac_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_env_${ac_var}_value=\$${ac_var}
+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
+ eval ac_cv_env_${ac_var}_value=\$${ac_var}
+done
#
# Report the --help message.
@@ -778,7 +1372,7 @@ 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 tcl 8.6 to adapt to many kinds of systems.
+\`configure' configures tcl 8.7 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -792,20 +1386,17 @@ Configuration:
--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
+ -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]
+ [$ac_default_prefix]
--exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [PREFIX]
+ [PREFIX]
By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
@@ -815,18 +1406,26 @@ 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]
+ --bindir=DIR user executables [EPREFIX/bin]
+ --sbindir=DIR system admin executables [EPREFIX/sbin]
+ --libexecdir=DIR program executables [EPREFIX/libexec]
+ --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]
+ --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
+ --libdir=DIR object code libraries [EPREFIX/lib]
+ --includedir=DIR C header files [PREFIX/include]
+ --oldincludedir=DIR C header files for non-gcc [/usr/include]
+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]
+ --infodir=DIR info documentation [DATAROOTDIR/info]
+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]
+ --mandir=DIR man documentation [DATAROOTDIR/man]
+ --docdir=DIR documentation root [DATAROOTDIR/doc/tcl]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
@@ -835,18 +1434,18 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of tcl 8.6:";;
+ short | recursive ) echo "Configuration of tcl 8.7:";;
esac
cat <<\_ACEOF
Optional Features:
+ --disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --enable-threads build with threads (default: on)
--enable-shared build and link with shared libraries (default: on)
--enable-time64bit force 64-bit time_t for 32-bit build (default: off)
--enable-64bit enable 64bit support (where applicable)
- --enable-wince enable Win/CE support (where applicable)
+ --enable-zipfs build with Zipfs support (default: on)
--enable-symbols build with debugging symbols (default: off)
--enable-embedded-manifest
embed manifest if possible (default: yes)
@@ -855,135 +1454,295 @@ Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--with-encoding encoding for configuration values
- --with-celib=DIR use Windows/CE support library from DIR
Some influential environment variables:
CC C compiler command
CFLAGS C compiler flags
LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
nonstandard directory <lib dir>
- CPPFLAGS C/C++ preprocessor flags, e.g. -I<include dir> if you have
- headers in a nonstandard directory <include dir>
+ LIBS libraries to pass to the linker, e.g. -l<library>
+ CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if
+ you have headers in a nonstandard directory <include dir>
CPP C preprocessor
Use these variables to override the choices made by `configure' or to help
it to find libraries and programs with nonstandard names/locations.
+Report bugs to the package provider.
_ACEOF
+ac_status=$?
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
+ test -d "$ac_dir" ||
+ { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && 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 "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
case $srcdir in
- .) # No --srcdir option. We are building in place.
+ .) # 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_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
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;;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
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
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
+
+ cd "$ac_dir" || { ac_status=$?; continue; }
+ # Check for configure.gnu first; this name is used for a wrapper for
+ # Metaconfig's "Configure" on case-insensitive file systems.
+ 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
else
- echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi
- cd $ac_popdir
+ printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2
+ fi || ac_status=$?
+ cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
-test -n "$ac_init_help" && exit 0
+test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-tcl configure 8.6
-generated by GNU Autoconf 2.59
+tcl configure 8.7
+generated by GNU Autoconf 2.71
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2021 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
+ exit
fi
-exec 5>config.log
-cat >&5 <<_ACEOF
+
+## ------------------------ ##
+## Autoconf initialization. ##
+## ------------------------ ##
+
+# ac_fn_c_try_compile LINENO
+# --------------------------
+# Try to compile conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest.beam
+ if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_compile
+
+# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
+# -------------------------------------------------------
+# Tests whether HEADER exists and can be compiled using the include files in
+# INCLUDES, setting the cache variable VAR accordingly.
+ac_fn_c_check_header_compile ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+printf %s "checking for $2... " >&6; }
+if eval test \${$3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+#include <$2>
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ eval "$3=yes"
+else $as_nop
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_header_compile
+
+# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
+# -------------------------------------------
+# Tests whether TYPE exists after having included INCLUDES, setting cache
+# variable VAR accordingly.
+ac_fn_c_check_type ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+printf %s "checking for $2... " >&6; }
+if eval test \${$3+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ eval "$3=no"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main (void)
+{
+if (sizeof ($2))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main (void)
+{
+if (sizeof (($2)))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+
+else $as_nop
+ eval "$3=yes"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+printf "%s\n" "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_type
+
+# ac_fn_c_try_cpp LINENO
+# ----------------------
+# Try to preprocess conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_cpp ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if { { ac_try="$ac_cpp conftest.$ac_ext"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } > conftest.i && {
+ test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ }
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_cpp
+ac_configure_args_raw=
+for ac_arg
+do
+ case $ac_arg in
+ *\'*)
+ ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ esac
+ as_fn_append ac_configure_args_raw " '$ac_arg'"
+done
+
+case $ac_configure_args_raw in
+ *$as_nl*)
+ ac_safe_unquote= ;;
+ *)
+ ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab.
+ ac_unsafe_a="$ac_unsafe_z#~"
+ ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g"
+ ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;;
+esac
+
+cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by tcl $as_me 8.6, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+It was created by tcl $as_me 8.7, which was
+generated by GNU Autoconf 2.71. Invocation command line was
- $ $0 $@
+ $ $0$ac_configure_args_raw
_ACEOF
+exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
@@ -1002,7 +1761,7 @@ uname -v = `(uname -v) 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`
+/usr/bin/hostinfo = `(/usr/bin/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`
@@ -1013,9 +1772,14 @@ 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
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ printf "%s\n" "PATH: $as_dir"
+ done
+IFS=$as_save_IFS
} >&5
@@ -1037,7 +1801,6 @@ _ACEOF
ac_configure_args=
ac_configure_args0=
ac_configure_args1=
-ac_sep=
ac_must_keep_next=false
for ac_pass in 1 2
do
@@ -1048,13 +1811,13 @@ do
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
- ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ *\'*)
+ ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
- 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
+ 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;
2)
- ac_configure_args1="$ac_configure_args1 '$ac_arg'"
+ as_fn_append ac_configure_args1 " '$ac_arg'"
if test $ac_must_keep_next = true; then
ac_must_keep_next=false # Got value, back to normal.
else
@@ -1070,217 +1833,558 @@ do
-* ) 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=" "
+ as_fn_append ac_configure_args " '$ac_arg'"
;;
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; }
+{ ac_configure_args0=; unset ac_configure_args0;}
+{ ac_configure_args1=; unset 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.
+# WARNING: Use '\'' to represent an apostrophe within the trap.
+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
+ # Sanitize IFS.
+ IFS=" "" $as_nl"
# Save into config.log some information that might help in debugging.
{
echo
- cat <<\_ASBOX
-## ---------------- ##
+ printf "%s\n" "## ---------------- ##
## Cache variables. ##
-## ---------------- ##
-_ASBOX
+## ---------------- ##"
echo
# The following way of writing the cache mishandles newlines in values,
-{
+(
+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
+ *) { eval $ac_var=; unset $ac_var;} ;;
+ esac ;;
+ esac
+ done
(set) 2>&1 |
- case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
- *ac_space=\ *)
+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
+ *${as_nl}ac_space=\ *)
sed -n \
- "s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
- ;;
+ "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"
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
- esac;
-}
+ esac |
+ sort
+)
echo
- cat <<\_ASBOX
-## ----------------- ##
+ printf "%s\n" "## ----------------- ##
## Output variables. ##
-## ----------------- ##
-_ASBOX
+## ----------------- ##"
echo
for ac_var in $ac_subst_vars
do
- eval ac_val=$`echo $ac_var`
- echo "$ac_var='"'"'$ac_val'"'"'"
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
- cat <<\_ASBOX
-## ------------- ##
-## Output files. ##
-## ------------- ##
-_ASBOX
+ printf "%s\n" "## ------------------- ##
+## File substitutions. ##
+## ------------------- ##"
echo
for ac_var in $ac_subst_files
do
- eval ac_val=$`echo $ac_var`
- echo "$ac_var='"'"'$ac_val'"'"'"
+ eval ac_val=\$$ac_var
+ case $ac_val in
+ *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
- cat <<\_ASBOX
-## ----------- ##
+ printf "%s\n" "## ----------- ##
## confdefs.h. ##
-## ----------- ##
-_ASBOX
+## ----------- ##"
echo
- sed "/^$/d" confdefs.h | sort
+ cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
- echo "$as_me: caught signal $ac_signal"
- echo "$as_me: exit $exit_status"
+ printf "%s\n" "$as_me: caught signal $ac_signal"
+ printf "%s\n" "$as_me: exit $exit_status"
} >&5
- rm -f core *.core &&
- rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
+ rm -f core *.core core.conftest.* &&
+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
- ' 0
+' 0
for ac_signal in 1 2 13 15; do
- trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
+ trap 'ac_signal='$ac_signal'; as_fn_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
+rm -f -r conftest* confdefs.h
+printf "%s\n" "/* confdefs.h */" > confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
-_ACEOF
+# Predefined preprocessor variables.
+printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_VERSION "$PACKAGE_VERSION"
-_ACEOF
+printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h
+printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_STRING "$PACKAGE_STRING"
-_ACEOF
+printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h
+printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
-_ACEOF
+printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h
# 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
+# Prefer an explicitly selected file to automatically selected ones.
+if test -n "$CONFIG_SITE"; then
+ ac_site_files="$CONFIG_SITE"
+elif test "x$prefix" != xNONE; then
+ ac_site_files="$prefix/share/config.site $prefix/etc/config.site"
+else
+ ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
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;}
+
+for ac_site_file in $ac_site_files
+do
+ case $ac_site_file in #(
+ */*) :
+ ;; #(
+ *) :
+ ac_site_file=./$ac_site_file ;;
+esac
+ if test -f "$ac_site_file" && test -r "$ac_site_file"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
+printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file"
+ . "$ac_site_file" \
+ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "failed to load site script $ac_site_file
+See \`config.log' for more details" "$LINENO" 5; }
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;}
+ # Some versions of bash will fail to source /dev/null (special files
+ # actually), so we avoid doing that. DJGPP emulates it as a regular file.
+ if test /dev/null != "$cache_file" && test -f "$cache_file"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
+printf "%s\n" "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
- [\\/]* | ?:[\\/]* ) . $cache_file;;
- *) . ./$cache_file;;
+ [\\/]* | ?:[\\/]* ) . "$cache_file";;
+ *) . "./$cache_file";;
esac
fi
else
- { echo "$as_me:$LINENO: creating cache $cache_file" >&5
-echo "$as_me: creating cache $cache_file" >&6;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
+printf "%s\n" "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
+# Test code for whether the C compiler supports C89 (global declarations)
+ac_c_conftest_c89_globals='
+/* Does the compiler advertise C89 conformance?
+ Do not test the value of __STDC__, because some compilers set it to 0
+ while being otherwise adequately conformant. */
+#if !defined __STDC__
+# error "Compiler does not advertise C89 conformance"
+#endif
+
+#include <stddef.h>
+#include <stdarg.h>
+struct stat;
+/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */
+struct buf { int x; };
+struct buf * (*rcsopen) (struct buf *, struct stat *, int);
+static char *e (p, i)
+ char **p;
+ int i;
+{
+ return p[i];
+}
+static char *f (char * (*g) (char **, int), char **p, ...)
+{
+ char *s;
+ va_list v;
+ va_start (v,p);
+ s = g (p, va_arg (v,int));
+ va_end (v);
+ return s;
+}
+
+/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
+ function prototypes and stuff, but not \xHH hex character constants.
+ These do not provoke an error unfortunately, instead are silently treated
+ as an "x". The following induces an error, until -std is added to get
+ proper ANSI mode. Curiously \x00 != x always comes out true, for an
+ array size at least. It is necessary to write \x00 == 0 to get something
+ that is true only with -std. */
+int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1];
+
+/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
+ inside strings and character constants. */
+#define FOO(x) '\''x'\''
+int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1];
+
+int test (int i, double x);
+struct s1 {int (*f) (int a);};
+struct s2 {int (*f) (double a);};
+int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int),
+ int, int);'
+
+# Test code for whether the C compiler supports C89 (body of main).
+ac_c_conftest_c89_main='
+ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]);
+'
+
+# Test code for whether the C compiler supports C99 (global declarations)
+ac_c_conftest_c99_globals='
+// Does the compiler advertise C99 conformance?
+#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
+# error "Compiler does not advertise C99 conformance"
+#endif
+
+#include <stdbool.h>
+extern int puts (const char *);
+extern int printf (const char *, ...);
+extern int dprintf (int, const char *, ...);
+extern void *malloc (size_t);
+
+// Check varargs macros. These examples are taken from C99 6.10.3.5.
+// dprintf is used instead of fprintf to avoid needing to declare
+// FILE and stderr.
+#define debug(...) dprintf (2, __VA_ARGS__)
+#define showlist(...) puts (#__VA_ARGS__)
+#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__))
+static void
+test_varargs_macros (void)
+{
+ int x = 1234;
+ int y = 5678;
+ debug ("Flag");
+ debug ("X = %d\n", x);
+ showlist (The first, second, and third items.);
+ report (x>y, "x is %d but y is %d", x, y);
+}
+
+// Check long long types.
+#define BIG64 18446744073709551615ull
+#define BIG32 4294967295ul
+#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0)
+#if !BIG_OK
+ #error "your preprocessor is broken"
+#endif
+#if BIG_OK
+#else
+ #error "your preprocessor is broken"
+#endif
+static long long int bignum = -9223372036854775807LL;
+static unsigned long long int ubignum = BIG64;
+
+struct incomplete_array
+{
+ int datasize;
+ double data[];
+};
+
+struct named_init {
+ int number;
+ const wchar_t *name;
+ double average;
+};
+
+typedef const char *ccp;
+
+static inline int
+test_restrict (ccp restrict text)
+{
+ // See if C++-style comments work.
+ // Iterate through items via the restricted pointer.
+ // Also check for declarations in for loops.
+ for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i)
+ continue;
+ return 0;
+}
+
+// Check varargs and va_copy.
+static bool
+test_varargs (const char *format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ va_list args_copy;
+ va_copy (args_copy, args);
+
+ const char *str = "";
+ int number = 0;
+ float fnumber = 0;
+
+ while (*format)
+ {
+ switch (*format++)
+ {
+ case '\''s'\'': // string
+ str = va_arg (args_copy, const char *);
+ break;
+ case '\''d'\'': // int
+ number = va_arg (args_copy, int);
+ break;
+ case '\''f'\'': // float
+ fnumber = va_arg (args_copy, double);
+ break;
+ default:
+ break;
+ }
+ }
+ va_end (args_copy);
+ va_end (args);
+
+ return *str && number && fnumber;
+}
+'
+
+# Test code for whether the C compiler supports C99 (body of main).
+ac_c_conftest_c99_main='
+ // Check bool.
+ _Bool success = false;
+ success |= (argc != 0);
+
+ // Check restrict.
+ if (test_restrict ("String literal") == 0)
+ success = true;
+ char *restrict newvar = "Another string";
+
+ // Check varargs.
+ success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234);
+ test_varargs_macros ();
+
+ // Check flexible array members.
+ struct incomplete_array *ia =
+ malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10));
+ ia->datasize = 10;
+ for (int i = 0; i < ia->datasize; ++i)
+ ia->data[i] = i * 1.234;
+
+ // Check named initializers.
+ struct named_init ni = {
+ .number = 34,
+ .name = L"Test wide string",
+ .average = 543.34343,
+ };
+
+ ni.number = 58;
+
+ int dynamic_array[ni.number];
+ dynamic_array[0] = argv[0][0];
+ dynamic_array[ni.number - 1] = 543;
+
+ // work around unused variable warnings
+ ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\''
+ || dynamic_array[ni.number - 1] != 543);
+'
+
+# Test code for whether the C compiler supports C11 (global declarations)
+ac_c_conftest_c11_globals='
+// Does the compiler advertise C11 conformance?
+#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L
+# error "Compiler does not advertise C11 conformance"
+#endif
+
+// Check _Alignas.
+char _Alignas (double) aligned_as_double;
+char _Alignas (0) no_special_alignment;
+extern char aligned_as_int;
+char _Alignas (0) _Alignas (int) aligned_as_int;
+
+// Check _Alignof.
+enum
+{
+ int_alignment = _Alignof (int),
+ int_array_alignment = _Alignof (int[100]),
+ char_alignment = _Alignof (char)
+};
+_Static_assert (0 < -_Alignof (int), "_Alignof is signed");
+
+// Check _Noreturn.
+int _Noreturn does_not_return (void) { for (;;) continue; }
+
+// Check _Static_assert.
+struct test_static_assert
+{
+ int x;
+ _Static_assert (sizeof (int) <= sizeof (long int),
+ "_Static_assert does not work in struct");
+ long int y;
+};
+
+// Check UTF-8 literals.
+#define u8 syntax error!
+char const utf8_literal[] = u8"happens to be ASCII" "another string";
+
+// Check duplicate typedefs.
+typedef long *long_ptr;
+typedef long int *long_ptr;
+typedef long_ptr long_ptr;
+
+// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1.
+struct anonymous
+{
+ union {
+ struct { int i; int j; };
+ struct { int k; long int l; } w;
+ };
+ int m;
+} v1;
+'
+
+# Test code for whether the C compiler supports C11 (body of main).
+ac_c_conftest_c11_main='
+ _Static_assert ((offsetof (struct anonymous, i)
+ == offsetof (struct anonymous, w.k)),
+ "Anonymous union alignment botch");
+ v1.i = 2;
+ v1.w.k = 5;
+ ok |= v1.i != 5;
+'
+
+# Test code for whether the C compiler supports C11 (complete).
+ac_c_conftest_c11_program="${ac_c_conftest_c89_globals}
+${ac_c_conftest_c99_globals}
+${ac_c_conftest_c11_globals}
+
+int
+main (int argc, char **argv)
+{
+ int ok = 0;
+ ${ac_c_conftest_c89_main}
+ ${ac_c_conftest_c99_main}
+ ${ac_c_conftest_c11_main}
+ return ok;
+}
+"
+
+# Test code for whether the C compiler supports C99 (complete).
+ac_c_conftest_c99_program="${ac_c_conftest_c89_globals}
+${ac_c_conftest_c99_globals}
+
+int
+main (int argc, char **argv)
+{
+ int ok = 0;
+ ${ac_c_conftest_c89_main}
+ ${ac_c_conftest_c99_main}
+ return ok;
+}
+"
+
+# Test code for whether the C compiler supports C89 (complete).
+ac_c_conftest_c89_program="${ac_c_conftest_c89_globals}
+
+int
+main (int argc, char **argv)
+{
+ int ok = 0;
+ ${ac_c_conftest_c89_main}
+ return ok;
+}
+"
+
+as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H"
+as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H"
+as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H"
+as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H"
+as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H"
+as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H"
+as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H"
+as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H"
+as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H"
# 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
+for ac_var in $ac_precious_vars; 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"
+ 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;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+printf "%s\n" "$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;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
+printf "%s\n" "$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=:
+ # differences in whitespace do not lead to failure.
+ ac_old_val_w=`echo x $ac_old_val`
+ ac_new_val_w=`echo x $ac_new_val`
+ if test "$ac_old_val_w" != "$ac_new_val_w"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
+printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ ac_cache_corrupted=:
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
+printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
+ eval $ac_var=\$ac_old_val
+ fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
+printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
+printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;}
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=`printf "%s\n" "$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'" ;;
+ *) as_fn_append 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; }; }
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
+printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;}
+ as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file'
+ and start over" "$LINENO" 5
fi
+## -------------------- ##
+## Main body of script. ##
+## -------------------- ##
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
@@ -1292,40 +2396,15 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
# The following define is needed when building with Cygwin since newer
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh
-TCL_VERSION=8.6
+TCL_VERSION=8.7
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL=".13"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a6"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.4
@@ -1368,6 +2447,15 @@ if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
+
+
+
+
+
+
+
+
+
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
@@ -1376,11 +2464,12 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
set dummy ${ac_tool_prefix}gcc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1388,37 +2477,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}gcc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_CC"; then
ac_ct_CC=$CC
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
@@ -1426,41 +2522,57 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="gcc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
- echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
-echo "${ECHO_T}$ac_ct_CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+printf "%s\n" "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- CC=$ac_ct_CC
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
else
CC="$ac_cv_prog_CC"
fi
if test -z "$CC"; then
- if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
set dummy ${ac_tool_prefix}cc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1468,79 +2580,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}cc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
-fi
-if test -z "$ac_cv_prog_CC"; then
- ac_ct_CC=$CC
- # Extract the first word of "cc", so it can be a program name with args.
-set dummy cc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if test -n "$ac_ct_CC"; then
- ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_CC="cc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
-done
-
-fi
-fi
-ac_ct_CC=$ac_cv_prog_ac_ct_CC
-if test -n "$ac_ct_CC"; then
- echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
-echo "${ECHO_T}$ac_ct_CC" >&6
-else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
-fi
-
- CC=$ac_ct_CC
-else
- CC="$ac_cv_prog_CC"
-fi
+ fi
fi
if test -z "$CC"; then
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1549,19 +2626,24 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
- if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
ac_prog_rejected=yes
continue
fi
ac_cv_prog_CC="cc"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
if test $ac_prog_rejected = yes; then
# We found a bogon in the path, so make sure we never use it.
@@ -1572,32 +2654,34 @@ if test $ac_prog_rejected = yes; then
# However, it has the same basename, so the bogon will be chosen
# first if we set CC to just the basename; use the full file name.
shift
- ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"
+ ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@"
fi
fi
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
- for ac_prog in cl
+ for ac_prog in cl.exe
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
@@ -1605,41 +2689,48 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
test -n "$CC" && break
done
fi
if test -z "$CC"; then
ac_ct_CC=$CC
- for ac_prog in cl
+ for ac_prog in cl.exe
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
@@ -1647,71 +2738,191 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="$ac_prog"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
- echo "$as_me:$LINENO: result: $ac_ct_CC" >&5
-echo "${ECHO_T}$ac_ct_CC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+printf "%s\n" "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
test -n "$ac_ct_CC" && break
done
- CC=$ac_ct_CC
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+fi
+
+fi
+if test -z "$CC"; then
+ if test -n "$ac_tool_prefix"; then
+ # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args.
+set dummy ${ac_tool_prefix}clang; ac_word=$2
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -n "$CC"; then
+ ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ ac_cv_prog_CC="${ac_tool_prefix}clang"
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+CC=$ac_cv_prog_CC
+if test -n "$CC"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+printf "%s\n" "$CC" >&6; }
+else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+fi
+
+
fi
+if test -z "$ac_cv_prog_CC"; then
+ ac_ct_CC=$CC
+ # Extract the first word of "clang", so it can be a program name with args.
+set dummy clang; ac_word=$2
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_CC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -n "$ac_ct_CC"; then
+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ ac_cv_prog_ac_ct_CC="clang"
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
fi
+fi
+ac_ct_CC=$ac_cv_prog_ac_ct_CC
+if test -n "$ac_ct_CC"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+printf "%s\n" "$ac_ct_CC" >&6; }
+else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+fi
+ if test "x$ac_ct_CC" = x; then
+ CC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
+else
+ CC="$ac_cv_prog_CC"
+fi
-test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH
-See \`config.log' for more details." >&5
-echo "$as_me: error: no acceptable C compiler found in \$PATH
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+fi
+
+
+test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "no acceptable C compiler found in \$PATH
+See \`config.log' for more details" "$LINENO" 5; }
# Provide some information about the compiler.
-echo "$as_me:$LINENO:" \
- "checking for C compiler version" >&5
-ac_compiler=`set X $ac_compile; echo $2`
-{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version </dev/null >&5\"") >&5
- (eval $ac_compiler --version </dev/null >&5) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }
-{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v </dev/null >&5\"") >&5
- (eval $ac_compiler -v </dev/null >&5) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }
-{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5
- (eval $ac_compiler -V </dev/null >&5) 2>&5
+printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5
+set X $ac_compile
+ac_compiler=$2
+for ac_option in --version -v -V -qversion -version; do
+ { { ac_try="$ac_compiler $ac_option >&5"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_compiler $ac_option >&5") 2>conftest.err
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }
+ if test -s conftest.err; then
+ sed '10a\
+... rest of stderr output deleted ...
+ 10q' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ fi
+ rm -f conftest.er1 conftest.err
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+done
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
@@ -1719,112 +2930,111 @@ main ()
}
_ACEOF
ac_clean_files_save=$ac_clean_files
-ac_clean_files="$ac_clean_files a.out a.exe b.out"
+ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
-echo "$as_me:$LINENO: checking for C compiler default output file name" >&5
-echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6
-ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
-if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5
- (eval $ac_link_default) 2>&5
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
+printf %s "checking whether the C compiler works... " >&6; }
+ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
+
+# The possible output files:
+ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"
+
+ac_rmfiles=
+for ac_file in $ac_files
+do
+ case $ac_file in
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;
+ esac
+done
+rm -f $ac_rmfiles
+
+if { { ac_try="$ac_link_default"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link_default") 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
- # Find the output, starting from the most likely. This scheme is
-# not robust to junk in `.', hence go to wildcards (a.*) only as a last
-# resort.
-
-# Be careful to initialize this variable, since it used to be cached.
-# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile.
-ac_cv_exeext=
-# b.out is created by i960 compilers.
-for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+then :
+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
+# in a Makefile. We should not override ac_cv_exeext if it was cached,
+# so that the user can short-circuit this test for compilers unknown to
+# Autoconf.
+for ac_file in $ac_files ''
do
test -f "$ac_file" || continue
case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj )
- ;;
- conftest.$ac_ext )
- # This is the source file.
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )
;;
[ab].out )
# We found the default executable, but exeext='' is most
# certainly right.
break;;
*.* )
- ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
- # FIXME: I believe we export ac_cv_exeext for Libtool,
- # but it would be cool to find out if it's true. Does anybody
- # maintain Libtool? --akim.
- export ac_cv_exeext
+ if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no;
+ then :; else
+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
+ fi
+ # We set ac_cv_exeext here because the later test for it is not
+ # safe: cross compilers may not add the suffix if given an `-o'
+ # argument, so we may need to know it at that point already.
+ # Even if this section looks crufty: it has the advantage of
+ # actually working.
break;;
* )
break;;
esac
done
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+test "$ac_cv_exeext" = no && ac_cv_exeext=
-{ { echo "$as_me:$LINENO: error: C compiler cannot create executables
-See \`config.log' for more details." >&5
-echo "$as_me: error: C compiler cannot create executables
-See \`config.log' for more details." >&2;}
- { (exit 77); exit 77; }; }
+else $as_nop
+ ac_file=''
fi
+if test -z "$ac_file"
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error 77 "C compiler cannot create executables
+See \`config.log' for more details" "$LINENO" 5; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
+printf %s "checking for C compiler default output file name... " >&6; }
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
+printf "%s\n" "$ac_file" >&6; }
ac_exeext=$ac_cv_exeext
-echo "$as_me:$LINENO: result: $ac_file" >&5
-echo "${ECHO_T}$ac_file" >&6
-# Check the compiler produces executables we can run. If not, either
-# the compiler is broken, or we cross compile.
-echo "$as_me:$LINENO: checking whether the C compiler works" >&5
-echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6
-# FIXME: These cross compiler hacks should be removed for Autoconf 3.0
-# If not cross compiling, check that we can run a simple program.
-if test "$cross_compiling" != yes; then
- if { ac_try='./$ac_file'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- cross_compiling=no
- else
- if test "$cross_compiling" = maybe; then
- cross_compiling=yes
- else
- { { echo "$as_me:$LINENO: error: cannot run C compiled programs.
-If you meant to cross compile, use \`--host'.
-See \`config.log' for more details." >&5
-echo "$as_me: error: cannot run C compiled programs.
-If you meant to cross compile, use \`--host'.
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
- fi
- fi
-fi
-echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
-
-rm -f a.out a.exe conftest$ac_cv_exeext b.out
+rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out
ac_clean_files=$ac_clean_files_save
-# Check the compiler produces executables we can run. If not, either
-# the compiler is broken, or we cross compile.
-echo "$as_me:$LINENO: checking whether we are cross compiling" >&5
-echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6
-echo "$as_me:$LINENO: result: $cross_compiling" >&5
-echo "${ECHO_T}$cross_compiling" >&6
-
-echo "$as_me:$LINENO: checking for suffix of executables" >&5
-echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
+printf %s "checking for suffix of executables... " >&6; }
+if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+then :
# If both `conftest.exe' and `conftest' are `present' (well, observable)
# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
# work properly (i.e., refer to `conftest.exe'), while it won't with
@@ -1832,42 +3042,95 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
for ac_file in conftest.exe conftest conftest.*; do
test -f "$ac_file" || continue
case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;;
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
*.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
- export ac_cv_exeext
break;;
* ) break;;
esac
done
-else
- { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link
-See \`config.log' for more details." >&5
-echo "$as_me: error: cannot compute suffix of executables: cannot compile and link
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+else $as_nop
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compute suffix of executables: cannot compile and link
+See \`config.log' for more details" "$LINENO" 5; }
fi
-
-rm -f conftest$ac_cv_exeext
-echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5
-echo "${ECHO_T}$ac_cv_exeext" >&6
+rm -f conftest conftest$ac_cv_exeext
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
+printf "%s\n" "$ac_cv_exeext" >&6; }
rm -f conftest.$ac_ext
EXEEXT=$ac_cv_exeext
ac_exeext=$EXEEXT
-echo "$as_me:$LINENO: checking for suffix of object files" >&5
-echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6
-if test "${ac_cv_objext+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <stdio.h>
+int
+main (void)
+{
+FILE *f = fopen ("conftest.out", "w");
+ return ferror (f) || fclose (f) != 0;
+
+ ;
+ return 0;
+}
_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ac_clean_files="$ac_clean_files conftest.out"
+# Check that the compiler produces executables we can run. If not, either
+# the compiler is broken, or we cross compile.
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
+printf %s "checking whether we are cross compiling... " >&6; }
+if test "$cross_compiling" != yes; then
+ { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+ if { ac_try='./conftest$ac_cv_exeext'
+ { { case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }; then
+ cross_compiling=no
+ else
+ if test "$cross_compiling" = maybe; then
+ cross_compiling=yes
+ else
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error 77 "cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details" "$LINENO" 5; }
+ fi
+ fi
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
+printf "%s\n" "$cross_compiling" >&6; }
+
+rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
+ac_clean_files=$ac_clean_files_save
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
+printf %s "checking for suffix of object files... " >&6; }
+if test ${ac_cv_objext+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
@@ -1875,49 +3138,52 @@ main ()
}
_ACEOF
rm -f conftest.o conftest.obj
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>&5
+if { { ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
- for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }
+then :
+ for ac_file in conftest.o conftest.obj conftest.*; do
+ test -f "$ac_file" || continue;
case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;;
+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;
*) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
break;;
esac
done
-else
- echo "$as_me: failed program was:" >&5
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
-{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile
-See \`config.log' for more details." >&5
-echo "$as_me: error: cannot compute suffix of object files: cannot compile
-See \`config.log' for more details." >&2;}
- { (exit 1); exit 1; }; }
+{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot compute suffix of object files: cannot compile
+See \`config.log' for more details" "$LINENO" 5; }
fi
-
rm -f conftest.$ac_cv_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_objext" >&5
-echo "${ECHO_T}$ac_cv_objext" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
+printf "%s\n" "$ac_cv_objext" >&6; }
OBJEXT=$ac_cv_objext
ac_objext=$OBJEXT
-echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5
-echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6
-if test "${ac_cv_c_compiler_gnu+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5
+printf %s "checking whether the compiler supports GNU C... " >&6; }
+if test ${ac_cv_c_compiler_gnu+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
#ifndef __GNUC__
choke me
@@ -1927,99 +3193,95 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_compiler_gnu=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_compiler_gnu=no
+else $as_nop
+ ac_compiler_gnu=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu
fi
-echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5
-echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6
-GCC=`test $ac_compiler_gnu = yes && echo yes`
-ac_test_CFLAGS=${CFLAGS+set}
-ac_save_CFLAGS=$CFLAGS
-CFLAGS="-g"
-echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5
-echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6
-if test "${ac_cv_prog_cc_g+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
+printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; }
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+if test $ac_compiler_gnu = yes; then
+ GCC=yes
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ GCC=
+fi
+ac_test_CFLAGS=${CFLAGS+y}
+ac_save_CFLAGS=$CFLAGS
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
+printf %s "checking whether $CC accepts -g... " >&6; }
+if test ${ac_cv_prog_cc_g+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_save_c_werror_flag=$ac_c_werror_flag
+ ac_c_werror_flag=yes
+ ac_cv_prog_cc_g=no
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_prog_cc_g=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+else $as_nop
+ CFLAGS=""
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
-ac_cv_prog_cc_g=no
+int
+main (void)
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+
+else $as_nop
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main (void)
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_g=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
-echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
-if test "$ac_test_CFLAGS" = set; then
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
+printf "%s\n" "$ac_cv_prog_cc_g" >&6; }
+if test $ac_test_CFLAGS; then
CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
if test "$GCC" = yes; then
@@ -2034,264 +3296,146 @@ else
CFLAGS=
fi
fi
-echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5
-echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6
-if test "${ac_cv_prog_cc_stdc+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- ac_cv_prog_cc_stdc=no
+ac_prog_cc_stdc=no
+if test x$ac_prog_cc_stdc = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5
+printf %s "checking for $CC option to enable C11 features... " >&6; }
+if test ${ac_cv_prog_cc_c11+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_prog_cc_c11=no
ac_save_CC=$CC
-cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-#include <stdarg.h>
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */
-struct buf { int x; };
-FILE * (*rcsopen) (struct buf *, struct stat *, int);
-static char *e (p, i)
- char **p;
- int i;
-{
- return p[i];
-}
-static char *f (char * (*g) (char **, int), char **p, ...)
-{
- char *s;
- va_list v;
- va_start (v,p);
- s = g (p, va_arg (v,int));
- va_end (v);
- return s;
-}
-
-/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
- function prototypes and stuff, but not '\xHH' hex character constants.
- These don't provoke an error unfortunately, instead are silently treated
- as 'x'. The following induces an error, until -std1 is added to get
- proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an
- array size at least. It's necessary to write '\x00'==0 to get something
- that's true only with -std1. */
-int osf4_cc_array ['\x00' == 0 ? 1 : -1];
-
-int test (int i, double x);
-struct s1 {int (*f) (int a);};
-struct s2 {int (*f) (double a);};
-int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);
-int argc;
-char **argv;
-int
-main ()
-{
-return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
- ;
- return 0;
-}
+$ac_c_conftest_c11_program
_ACEOF
-# Don't try gcc -ansi; that turns off useful extensions and
-# breaks some systems' header files.
-# AIX -qlanglvl=ansi
-# Ultrix and OSF/1 -std1
-# HP-UX 10.20 and later -Ae
-# HP-UX older versions -Aa -D_HPUX_SOURCE
-# SVR4 -Xc -D__EXTENSIONS__
-for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+for ac_arg in '' -std=gnu11
do
CC="$ac_save_CC $ac_arg"
- rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_prog_cc_stdc=$ac_arg
-break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+ if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_c11=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext
+rm -f core conftest.err conftest.$ac_objext conftest.beam
+ test "x$ac_cv_prog_cc_c11" != "xno" && break
done
-rm -f conftest.$ac_ext conftest.$ac_objext
+rm -f conftest.$ac_ext
CC=$ac_save_CC
-
fi
-case "x$ac_cv_prog_cc_stdc" in
- x|xno)
- echo "$as_me:$LINENO: result: none needed" >&5
-echo "${ECHO_T}none needed" >&6 ;;
- *)
- echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5
-echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6
- CC="$CC $ac_cv_prog_cc_stdc" ;;
-esac
-
-# Some people use a C++ compiler to compile C. Since we use `exit',
-# in C++ we need to declare it. In case someone uses the same compiler
-# for both compiling C and C++ we need to have the C++ compiler decide
-# the declaration of exit, since it's the most demanding environment.
-cat >conftest.$ac_ext <<_ACEOF
-#ifndef __cplusplus
- choke me
-#endif
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- for ac_declaration in \
- '' \
- 'extern "C" void std::exit (int) throw (); using std::exit;' \
- 'extern "C" void std::exit (int); using std::exit;' \
- 'extern "C" void exit (int) throw ();' \
- 'extern "C" void exit (int);' \
- 'void exit (int);'
-do
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+if test "x$ac_cv_prog_cc_c11" = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+printf "%s\n" "unsupported" >&6; }
+else $as_nop
+ if test "x$ac_cv_prog_cc_c11" = x
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+printf "%s\n" "none needed" >&6; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5
+printf "%s\n" "$ac_cv_prog_cc_c11" >&6; }
+ CC="$CC $ac_cv_prog_cc_c11"
+fi
+ ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11
+ ac_prog_cc_stdc=c11
+fi
+fi
+if test x$ac_prog_cc_stdc = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5
+printf %s "checking for $CC option to enable C99 features... " >&6; }
+if test ${ac_cv_prog_cc_c99+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_prog_cc_c99=no
+ac_save_CC=$CC
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-$ac_declaration
-#include <stdlib.h>
-int
-main ()
-{
-exit (42);
- ;
- return 0;
-}
+$ac_c_conftest_c99_program
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-continue
+for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99=
+do
+ CC="$ac_save_CC $ac_arg"
+ if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_c99=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+rm -f core conftest.err conftest.$ac_objext conftest.beam
+ test "x$ac_cv_prog_cc_c99" != "xno" && break
+done
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
+fi
+
+if test "x$ac_cv_prog_cc_c99" = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+printf "%s\n" "unsupported" >&6; }
+else $as_nop
+ if test "x$ac_cv_prog_cc_c99" = x
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+printf "%s\n" "none needed" >&6; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5
+printf "%s\n" "$ac_cv_prog_cc_c99" >&6; }
+ CC="$CC $ac_cv_prog_cc_c99"
+fi
+ ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99
+ ac_prog_cc_stdc=c99
+fi
+fi
+if test x$ac_prog_cc_stdc = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5
+printf %s "checking for $CC option to enable C89 features... " >&6; }
+if test ${ac_cv_prog_cc_c89+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ ac_cv_prog_cc_c89=no
+ac_save_CC=$CC
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
-$ac_declaration
-int
-main ()
-{
-exit (42);
- ;
- return 0;
-}
+$ac_c_conftest_c89_program
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
+do
+ CC="$ac_save_CC $ac_arg"
+ if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_prog_cc_c89=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam
+ test "x$ac_cv_prog_cc_c89" != "xno" && break
done
-rm -f conftest*
-if test -n "$ac_declaration"; then
- echo '#ifdef __cplusplus' >>confdefs.h
- echo $ac_declaration >>confdefs.h
- echo '#endif' >>confdefs.h
+rm -f conftest.$ac_ext
+CC=$ac_save_CC
fi
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+if test "x$ac_cv_prog_cc_c89" = xno
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+printf "%s\n" "unsupported" >&6; }
+else $as_nop
+ if test "x$ac_cv_prog_cc_c89" = x
+then :
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+printf "%s\n" "none needed" >&6; }
+else $as_nop
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
+printf "%s\n" "$ac_cv_prog_cc_c89" >&6; }
+ CC="$CC $ac_cv_prog_cc_c89"
+fi
+ ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89
+ ac_prog_cc_stdc=c89
+fi
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
@@ -2299,61 +3443,34 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $
ac_compiler_gnu=$ac_cv_c_compiler_gnu
-echo "$as_me:$LINENO: checking for inline" >&5
-echo $ECHO_N "checking for inline... $ECHO_C" >&6
-if test "${ac_cv_c_inline+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
+printf %s "checking for inline... " >&6; }
+if test ${ac_cv_c_inline+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
ac_cv_c_inline=no
for ac_kw in inline __inline__ __inline; do
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef __cplusplus
typedef int foo_t;
-static $ac_kw foo_t static_foo () {return 0; }
-$ac_kw foo_t foo () {return 0; }
+static $ac_kw foo_t static_foo (void) {return 0; }
+$ac_kw foo_t foo (void) {return 0; }
#endif
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_c_inline=$ac_kw; break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
+if ac_fn_c_try_compile "$LINENO"
+then :
+ ac_cv_c_inline=$ac_kw
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ test "$ac_cv_c_inline" != no && break
done
fi
-echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5
-echo "${ECHO_T}$ac_cv_c_inline" >&6
-
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
+printf "%s\n" "$ac_cv_c_inline" >&6; }
case $ac_cv_c_inline in
inline | yes) ;;
@@ -2370,432 +3487,16 @@ _ACEOF
;;
esac
-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
-echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5
-echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6
-# On Suns, sometimes $CPP names a directory.
-if test -n "$CPP" && test -d "$CPP"; then
- CPP=
-fi
-if test -z "$CPP"; then
- if test "${ac_cv_prog_CPP+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- # Double quotes because CPP needs to be expanded
- for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"
- do
- ac_preproc_ok=false
-for ac_c_preproc_warn_flag in '' yes
-do
- # Use a header file that comes with gcc, so configuring glibc
- # with a fresh cross-compiler works.
- # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- # <limits.h> exists even on freestanding compilers.
- # On the NeXT, cc -E runs the code through the compiler's parser,
- # not just through cpp. "Syntax error" is here to catch this case.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
- Syntax error
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- # Broken: fails on valid input.
-continue
-fi
-rm -f conftest.err conftest.$ac_ext
-
- # OK, works on sane cases. Now check whether non-existent headers
- # can be detected and how.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <ac_nonexistent.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- # Broken: success on invalid input.
-continue
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- # Passes both tests.
-ac_preproc_ok=:
-break
-fi
-rm -f conftest.err conftest.$ac_ext
-
-done
-# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
-rm -f conftest.err conftest.$ac_ext
-if $ac_preproc_ok; then
- break
-fi
-
- done
- ac_cv_prog_CPP=$CPP
-
-fi
- CPP=$ac_cv_prog_CPP
-else
- ac_cv_prog_CPP=$CPP
-fi
-echo "$as_me:$LINENO: result: $CPP" >&5
-echo "${ECHO_T}$CPP" >&6
-ac_preproc_ok=false
-for ac_c_preproc_warn_flag in '' yes
-do
- # Use a header file that comes with gcc, so configuring glibc
- # with a fresh cross-compiler works.
- # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since
- # <limits.h> exists even on freestanding compilers.
- # On the NeXT, cc -E runs the code through the compiler's parser,
- # not just through cpp. "Syntax error" is here to catch this case.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
- Syntax error
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- # Broken: fails on valid input.
-continue
-fi
-rm -f conftest.err conftest.$ac_ext
-
- # OK, works on sane cases. Now check whether non-existent headers
- # can be detected and how.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <ac_nonexistent.h>
-_ACEOF
-if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
- (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } >/dev/null; then
- if test -s conftest.err; then
- ac_cpp_err=$ac_c_preproc_warn_flag
- ac_cpp_err=$ac_cpp_err$ac_c_werror_flag
- else
- ac_cpp_err=
- fi
-else
- ac_cpp_err=yes
-fi
-if test -z "$ac_cpp_err"; then
- # Broken: success on invalid input.
-continue
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- # Passes both tests.
-ac_preproc_ok=:
-break
-fi
-rm -f conftest.err conftest.$ac_ext
-
-done
-# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
-rm -f conftest.err conftest.$ac_ext
-if $ac_preproc_ok; then
- :
-else
- { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check
-See \`config.log' for more details." >&5
-echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check
-See \`config.log' for more details." >&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
-
-
-echo "$as_me:$LINENO: checking for egrep" >&5
-echo $ECHO_N "checking for egrep... $ECHO_C" >&6
-if test "${ac_cv_prog_egrep+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if echo a | (grep -E '(a|b)') >/dev/null 2>&1
- then ac_cv_prog_egrep='grep -E'
- else ac_cv_prog_egrep='egrep'
- fi
-fi
-echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5
-echo "${ECHO_T}$ac_cv_prog_egrep" >&6
- EGREP=$ac_cv_prog_egrep
-
-
-echo "$as_me:$LINENO: checking for ANSI C header files" >&5
-echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6
-if test "${ac_cv_header_stdc+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <stdlib.h>
-#include <stdarg.h>
-#include <string.h>
-#include <float.h>
-
-int
-main ()
-{
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_header_stdc=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_header_stdc=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-if test $ac_cv_header_stdc = yes; then
- # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <string.h>
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "memchr" >/dev/null 2>&1; then
- :
-else
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-fi
-
-if test $ac_cv_header_stdc = yes; then
- # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <stdlib.h>
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "free" >/dev/null 2>&1; then
- :
-else
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-fi
-
-if test $ac_cv_header_stdc = yes; then
- # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
- if test "$cross_compiling" = yes; then
- :
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-#include <ctype.h>
-#include <stdlib.h>
-#if ((' ' & 0x0FF) == 0x020)
-# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
-# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
-#else
-# define ISLOWER(c) \
- (('a' <= (c) && (c) <= 'i') \
- || ('j' <= (c) && (c) <= 'r') \
- || ('s' <= (c) && (c) <= 'z'))
-# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))
-#endif
-
-#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
-int
-main ()
-{
- int i;
- for (i = 0; i < 256; i++)
- if (XOR (islower (i), ISLOWER (i))
- || toupper (i) != TOUPPER (i))
- exit(2);
- exit (0);
-}
-_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- :
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-ac_cv_header_stdc=no
-fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
-fi
-fi
-fi
-echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
-echo "${ECHO_T}$ac_cv_header_stdc" >&6
-if test $ac_cv_header_stdc = yes; then
-
-cat >>confdefs.h <<\_ACEOF
-#define STDC_HEADERS 1
-_ACEOF
-
-fi
-
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args.
set dummy ${ac_tool_prefix}ar; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_AR+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_AR+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
else
@@ -2803,37 +3504,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_AR="${ac_tool_prefix}ar"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
AR=$ac_cv_prog_AR
if test -n "$AR"; then
- echo "$as_me:$LINENO: result: $AR" >&5
-echo "${ECHO_T}$AR" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
+printf "%s\n" "$AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_AR"; then
ac_ct_AR=$AR
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_AR+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_AR+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_AR"; then
ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
else
@@ -2841,28 +3549,43 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_AR="ar"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_AR=$ac_cv_prog_ac_ct_AR
if test -n "$ac_ct_AR"; then
- echo "$as_me:$LINENO: result: $ac_ct_AR" >&5
-echo "${ECHO_T}$ac_ct_AR" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
+printf "%s\n" "$ac_ct_AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- AR=$ac_ct_AR
+ if test "x$ac_ct_AR" = x; then
+ AR=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ AR=$ac_ct_AR
+ fi
else
AR="$ac_cv_prog_AR"
fi
@@ -2870,11 +3593,12 @@ fi
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
set dummy ${ac_tool_prefix}ranlib; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_RANLIB+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_RANLIB+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
@@ -2882,37 +3606,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
RANLIB=$ac_cv_prog_RANLIB
if test -n "$RANLIB"; then
- echo "$as_me:$LINENO: result: $RANLIB" >&5
-echo "${ECHO_T}$RANLIB" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
+printf "%s\n" "$RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_RANLIB"; then
ac_ct_RANLIB=$RANLIB
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_RANLIB+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_RANLIB"; then
ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
else
@@ -2920,28 +3651,43 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RANLIB="ranlib"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB
if test -n "$ac_ct_RANLIB"; then
- echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5
-echo "${ECHO_T}$ac_ct_RANLIB" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
+printf "%s\n" "$ac_ct_RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- RANLIB=$ac_ct_RANLIB
+ if test "x$ac_ct_RANLIB" = x; then
+ RANLIB=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ RANLIB=$ac_ct_RANLIB
+ fi
else
RANLIB="$ac_cv_prog_RANLIB"
fi
@@ -2949,11 +3695,12 @@ fi
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args.
set dummy ${ac_tool_prefix}windres; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_RC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_RC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$RC"; then
ac_cv_prog_RC="$RC" # Let the user override the test.
else
@@ -2961,37 +3708,44 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_RC="${ac_tool_prefix}windres"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
RC=$ac_cv_prog_RC
if test -n "$RC"; then
- echo "$as_me:$LINENO: result: $RC" >&5
-echo "${ECHO_T}$RC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RC" >&5
+printf "%s\n" "$RC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+
fi
if test -z "$ac_cv_prog_RC"; then
ac_ct_RC=$RC
# Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_ac_ct_RC+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_ac_ct_RC+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$ac_ct_RC"; then
ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test.
else
@@ -2999,28 +3753,43 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RC="windres"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
fi
fi
ac_ct_RC=$ac_cv_prog_ac_ct_RC
if test -n "$ac_ct_RC"; then
- echo "$as_me:$LINENO: result: $ac_ct_RC" >&5
-echo "${ECHO_T}$ac_ct_RC" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5
+printf "%s\n" "$ac_ct_RC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
- RC=$ac_ct_RC
+ if test "x$ac_ct_RC" = x; then
+ RC=""
+ else
+ case $cross_compiling:$ac_tool_warned in
+yes:)
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ RC=$ac_ct_RC
+ fi
else
RC="$ac_cv_prog_RC"
fi
@@ -3030,13 +3799,14 @@ fi
# Checks to see if the make program sets the $MAKE variable.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5
-echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5
+printf %s "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; }
set x ${MAKE-make}
-ac_make=`echo "" | sed 'y,:./+-,___p_,'`
-if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+ac_make=`printf "%s\n" "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'`
+if eval test \${ac_cv_prog_make_${ac_make}_set+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
cat >conftest.make <<\_ACEOF
SHELL = /bin/sh
all:
@@ -3052,12 +3822,12 @@ esac
rm -f conftest.make
fi
if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
SET_MAKE=
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
SET_MAKE="MAKE=${MAKE-make}"
fi
@@ -3069,65 +3839,24 @@ fi
-#--------------------------------------------------------------------
-# Check whether --enable-threads or --disable-threads was given.
-#--------------------------------------------------------------------
-
-
- echo "$as_me:$LINENO: checking for building with threads" >&5
-echo $ECHO_N "checking for building with threads... $ECHO_C" >&6
- # Check whether --enable-threads or --disable-threads was given.
-if test "${enable_threads+set}" = set; then
- enableval="$enable_threads"
- tcl_ok=$enableval
-else
- tcl_ok=yes
-fi;
-
- if test "$tcl_ok" = "yes"; then
- echo "$as_me:$LINENO: result: yes (default)" >&5
-echo "${ECHO_T}yes (default)" >&6
- TCL_THREADS=1
- cat >>confdefs.h <<\_ACEOF
-#define TCL_THREADS 1
-_ACEOF
-
- # USE_THREAD_ALLOC tells us to try the special thread-based
- # allocator that significantly reduces lock contention
- cat >>confdefs.h <<\_ACEOF
-#define USE_THREAD_ALLOC 1
-_ACEOF
-
- else
- TCL_THREADS=0
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
- fi
-
-
-
#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
-# Check whether --with-encoding or --without-encoding was given.
-if test "${with_encoding+set}" = set; then
- withval="$with_encoding"
- with_tcencoding=${withval}
-fi;
+# Check whether --with-encoding was given.
+if test ${with_encoding+y}
+then :
+ withval=$with_encoding; with_tcencoding=${withval}
+fi
+
if test x"${with_tcencoding}" != x ; then
- cat >>confdefs.h <<_ACEOF
-#define TCL_CFGVAL_ENCODING "${with_tcencoding}"
-_ACEOF
+ printf "%s\n" "#define TCL_CFGVAL_ENCODING \"${with_tcencoding}\"" >>confdefs.h
else
- # Default encoding on windows is not "iso8859-1"
- cat >>confdefs.h <<\_ACEOF
-#define TCL_CFGVAL_ENCODING "cp1252"
-_ACEOF
+ printf "%s\n" "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h
fi
@@ -3138,46 +3867,47 @@ _ACEOF
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking how to build libraries" >&5
-echo $ECHO_N "checking how to build libraries... $ECHO_C" >&6
- # Check whether --enable-shared or --disable-shared was given.
-if test "${enable_shared+set}" = set; then
- enableval="$enable_shared"
- tcl_ok=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
+printf %s "checking how to build libraries... " >&6; }
+ # Check whether --enable-shared was given.
+if test ${enable_shared+y}
+then :
+ enableval=$enable_shared; tcl_ok=$enableval
+else $as_nop
tcl_ok=yes
-fi;
+fi
+
if test "$tcl_ok" = "yes" ; then
- echo "$as_me:$LINENO: result: shared" >&5
-echo "${ECHO_T}shared" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5
+printf "%s\n" "shared" >&6; }
SHARED_BUILD=1
else
- echo "$as_me:$LINENO: result: static" >&5
-echo "${ECHO_T}static" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5
+printf "%s\n" "static" >&6; }
SHARED_BUILD=0
-cat >>confdefs.h <<\_ACEOF
-#define STATIC_BUILD 1
-_ACEOF
+printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h
fi
+
#--------------------------------------------------------------------
# Check whether --enable-time64bit was given.
#--------------------------------------------------------------------
-echo "$as_me:$LINENO: checking force of 64-bit time_t" >&5
-echo $ECHO_N "checking force of 64-bit time_t... $ECHO_C" >&6
-# Check whether --enable-time64bit or --disable-time64bit was given.
-if test "${enable_time64bit+set}" = set; then
- enableval="$enable_time64bit"
- tcl_ok=$enableval
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking force of 64-bit time_t" >&5
+printf %s "checking force of 64-bit time_t... " >&6; }
+# Check whether --enable-time64bit was given.
+if test ${enable_time64bit+y}
+then :
+ enableval=$enable_time64bit; tcl_ok=$enableval
+else $as_nop
tcl_ok=no
-fi;
-echo "$as_me:$LINENO: result: \"$tcl_ok\"" >&5
-echo "${ECHO_T}\"$tcl_ok\"" >&6
+fi
+
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"$tcl_ok\"" >&5
+printf "%s\n" "\"$tcl_ok\"" >&6; }
if test "$tcl_ok" = "yes"; then
CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T"
fi
@@ -3188,64 +3918,66 @@ fi
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
+ac_header= ac_cache=
+for ac_item in $ac_header_c_list
+do
+ if test $ac_cache; then
+ ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default"
+ if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then
+ printf "%s\n" "#define $ac_item 1" >> confdefs.h
+ fi
+ ac_header= ac_cache=
+ elif test $ac_header; then
+ ac_cache=$ac_item
+ else
+ ac_header=$ac_item
+ fi
+done
+
+
+
+
+
+
+
+
+if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes
+then :
+
+printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h
+
+fi
# Step 0: Enable 64 bit support?
- echo "$as_me:$LINENO: checking if 64bit support is requested" >&5
-echo $ECHO_N "checking if 64bit support is requested... $ECHO_C" >&6
- # Check whether --enable-64bit or --disable-64bit was given.
-if test "${enable_64bit+set}" = set; then
- enableval="$enable_64bit"
- do64bit=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
+printf %s "checking if 64bit support is requested... " >&6; }
+ # Check whether --enable-64bit was given.
+if test ${enable_64bit+y}
+then :
+ enableval=$enable_64bit; do64bit=$enableval
+else $as_nop
do64bit=no
-fi;
- echo "$as_me:$LINENO: result: $do64bit" >&5
-echo "${ECHO_T}$do64bit" >&6
-
- # Cross-compiling options for Windows/CE builds
-
- echo "$as_me:$LINENO: checking if Windows/CE build is requested" >&5
-echo $ECHO_N "checking if Windows/CE build is requested... $ECHO_C" >&6
- # Check whether --enable-wince or --disable-wince was given.
-if test "${enable_wince+set}" = set; then
- enableval="$enable_wince"
- doWince=$enableval
-else
- doWince=no
-fi;
- echo "$as_me:$LINENO: result: $doWince" >&5
-echo "${ECHO_T}$doWince" >&6
-
- echo "$as_me:$LINENO: checking for Windows/CE celib directory" >&5
-echo $ECHO_N "checking for Windows/CE celib directory... $ECHO_C" >&6
-
-# Check whether --with-celib or --without-celib was given.
-if test "${with_celib+set}" = set; then
- withval="$with_celib"
- CELIB_DIR=$withval
-else
- CELIB_DIR=NO_CELIB
-fi;
- echo "$as_me:$LINENO: result: $CELIB_DIR" >&5
-echo "${ECHO_T}$CELIB_DIR" >&6
+fi
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
+printf "%s\n" "$do64bit" >&6; }
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
-cat >>confdefs.h <<\_ACEOF
-#define MODULE_SCOPE extern
-_ACEOF
+printf "%s\n" "#define MODULE_SCOPE extern" >>confdefs.h
# Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
-echo "$as_me:$LINENO: checking for $ac_word" >&5
-echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6
-if test "${ac_cv_prog_CYGPATH+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_CYGPATH+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
if test -n "$CYGPATH"; then
ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test.
else
@@ -3253,29 +3985,77 @@ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for ac_exec_ext in '' $ac_executable_extensions; do
- if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CYGPATH="cygpath -m"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
-done
+ done
+IFS=$as_save_IFS
test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo"
fi
fi
CYGPATH=$ac_cv_prog_CYGPATH
if test -n "$CYGPATH"; then
- echo "$as_me:$LINENO: result: $CYGPATH" >&5
-echo "${ECHO_T}$CYGPATH" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5
+printf "%s\n" "$CYGPATH" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
fi
+ # Extract the first word of "wine", so it can be a program name with args.
+set dummy wine; ac_word=$2
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+printf %s "checking for $ac_word... " >&6; }
+if test ${ac_cv_prog_WINE+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -n "$WINE"; then
+ ac_cv_prog_WINE="$WINE" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
+ ac_cv_prog_WINE="wine"
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+fi
+fi
+WINE=$ac_cv_prog_WINE
+if test -n "$WINE"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $WINE" >&5
+printf "%s\n" "$WINE" >&6; }
+else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+fi
+
+
+
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
@@ -3284,16 +4064,13 @@ fi
if test "$GCC" = "yes"; then
- echo "$as_me:$LINENO: checking for cross-compile version of gcc" >&5
-echo $ECHO_N "checking for cross-compile version of gcc... $ECHO_C" >&6
-if test "${ac_cv_cross+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cross-compile version of gcc" >&5
+printf %s "checking for cross-compile version of gcc... " >&6; }
+if test ${ac_cv_cross+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef _WIN32
@@ -3301,47 +4078,24 @@ cat >>conftest.$ac_ext <<_ACEOF
#endif
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_cross=no
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_cross=yes
+else $as_nop
+ ac_cv_cross=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_cross" >&5
-echo "${ECHO_T}$ac_cv_cross" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5
+printf "%s\n" "$ac_cv_cross" >&6; }
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
@@ -3383,20 +4137,20 @@ echo "${ECHO_T}$ac_cv_cross" >&6
echo "101 \"name\"" >> $conftest
echo "END" >> $conftest
- echo "$as_me:$LINENO: checking for Windows native path bug in windres" >&5
-echo $ECHO_N "checking for Windows native path bug in windres... $ECHO_C" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Windows native path bug in windres" >&5
+printf %s "checking for Windows native path bug in windres... " >&6; }
cyg_conftest=`$CYGPATH $conftest`
if { ac_try='$RC -o conftest.res.o $cyg_conftest'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_try\""; } >&5
(eval $ac_try) 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } ; then
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; } ; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
else
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
CYGPATH=echo
fi
conftest=
@@ -3414,16 +4168,13 @@ echo "${ECHO_T}yes" >&6
if test "${GCC}" = "yes" ; then
extra_cflags="-pipe"
extra_ldflags="-pipe -static-libgcc"
- echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5
-echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6
-if test "${ac_cv_win32+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mingw32 version of gcc" >&5
+printf %s "checking for mingw32 version of gcc... " >&6; }
+if test ${ac_cv_win32+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef _WIN32
@@ -3431,115 +4182,111 @@ cat >>conftest.$ac_ext <<_ACEOF
#endif
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_win32=no
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_win32=yes
+else $as_nop
+ ac_cv_win32=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_win32" >&5
-echo "${ECHO_T}$ac_cv_win32" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_win32" >&5
+printf "%s\n" "$ac_cv_win32" >&6; }
if test "$ac_cv_win32" != "yes"; then
- { { echo "$as_me:$LINENO: error: ${CC} cannot produce win32 executables." >&5
-echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;}
- { (exit 1); exit 1; }; }
+ as_fn_error $? "${CC} cannot produce win32 executables." "$LINENO" 5
fi
if test "$do64bit" != "arm64"; then
extra_cflags="$extra_cflags -DHAVE_CPUID=1"
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
- echo "$as_me:$LINENO: checking for working -municode linker flag" >&5
-echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6
-if test "${ac_cv_municode+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working -municode linker flag" >&5
+printf %s "checking for working -municode linker flag... " >&6; }
+if test ${ac_cv_municode+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+# ac_fn_c_try_link LINENO
+# -----------------------
+# Try to link conftest.$ac_ext, and return whether this succeeded.
+ac_fn_c_try_link ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>conftest.err
+ ac_status=$?
+ if test -s conftest.err; then
+ grep -v '^ *+' conftest.err >conftest.er1
+ cat conftest.er1 >&5
+ mv -f conftest.er1 conftest.err
+ fi
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest$ac_exeext && {
+ test "$cross_compiling" = yes ||
+ test -x conftest$ac_exeext
+ }
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=1
+fi
+ # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
+ # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
+ # interfere with the next link command; also delete a directory that is
+ # left behind by Apple's compiler. We do this before executing the actions.
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_link
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <windows.h>
int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;}
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
ac_cv_municode=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_municode=no
+else $as_nop
+ ac_cv_municode=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_municode" >&5
-echo "${ECHO_T}$ac_cv_municode" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_municode" >&5
+printf "%s\n" "$ac_cv_municode" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_municode" = "yes" ; then
extra_ldflags="$extra_ldflags -municode"
@@ -3547,136 +4294,117 @@ echo "${ECHO_T}$ac_cv_municode" >&6
extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto"
- echo "$as_me:$LINENO: checking for working -fno-lto" >&5
-echo $ECHO_N "checking for working -fno-lto... $ECHO_C" >&6
-if test "${ac_cv_nolto+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working -fno-lto" >&5
+printf %s "checking for working -fno-lto... " >&6; }
+if test ${ac_cv_nolto+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_nolto=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_nolto=no
+else $as_nop
+ ac_cv_nolto=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_nolto" >&5
-echo "${ECHO_T}$ac_cv_nolto" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_nolto" >&5
+printf "%s\n" "$ac_cv_nolto" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_nolto" = "yes" ; then
CFLAGS_NOLTO="-fno-lto"
else
CFLAGS_NOLTO=""
fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -finput-charset" >&5
+printf %s "checking if the compiler understands -finput-charset... " >&6; }
+if test ${tcl_cv_cc_input_charset+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main (void)
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"
+then :
+ tcl_cv_cc_input_charset=yes
+else $as_nop
+ tcl_cv_cc_input_charset=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+ CFLAGS=$hold_cflags
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_input_charset" >&5
+printf "%s\n" "$tcl_cv_cc_input_charset" >&6; }
+ if test $tcl_cv_cc_input_charset = yes; then
+ extra_cflags="$extra_cflags -finput-charset=UTF-8"
+ fi
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--enable-auto-image-base"
- echo "$as_me:$LINENO: checking for working --enable-auto-image-base" >&5
-echo $ECHO_N "checking for working --enable-auto-image-base... $ECHO_C" >&6
-if test "${ac_cv_enable_auto_image_base+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working --enable-auto-image-base" >&5
+printf %s "checking for working --enable-auto-image-base... " >&6; }
+if test ${ac_cv_enable_auto_image_base+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
ac_cv_enable_auto_image_base=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_enable_auto_image_base=no
+else $as_nop
+ ac_cv_enable_auto_image_base=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_enable_auto_image_base" >&5
-echo "${ECHO_T}$ac_cv_enable_auto_image_base" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_enable_auto_image_base" >&5
+printf "%s\n" "$ac_cv_enable_auto_image_base" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_enable_auto_image_base" == "yes" ; then
extra_ldflags="$extra_ldflags -Wl,--enable-auto-image-base"
fi
- echo "$as_me:$LINENO: checking compiler flags" >&5
-echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking compiler flags" >&5
+printf %s "checking compiler flags... " >&6; }
if test "${GCC}" = "yes" ; then
SHLIB_LD=""
SHLIB_LD_LIBS='${LIBS}'
LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32"
# mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't
- LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32"
+ LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32 -lwinspool"
STLIB_LD='${AR} cr'
RC_OUT=-o
RC_TYPE=
@@ -3691,29 +4419,26 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
if test "${SHARED_BUILD}" = "0" ; then
# static
- echo "$as_me:$LINENO: result: using static flags" >&5
-echo "${ECHO_T}using static flags" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
+printf "%s\n" "using static flags" >&6; }
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
- EXESUFFIX="s\${DBGX}.exe"
+ EXESUFFIX="s.exe"
else
# dynamic
- echo "$as_me:$LINENO: result: using shared flags" >&5
-echo "${ECHO_T}using shared flags" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
+printf "%s\n" "using shared flags" >&6; }
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
- { { echo "$as_me:$LINENO: error: ${CC} does not support the -shared option.
- You will need to upgrade to a newer version of the toolchain." >&5
-echo "$as_me: error: ${CC} does not support the -shared option.
- You will need to upgrade to a newer version of the toolchain." >&2;}
- { (exit 1); exit 1; }; }
+ as_fn_error $? "${CC} does not support the -shared option.
+ You will need to upgrade to a newer version of the toolchain." "$LINENO" 5
fi
runtime=
# Add SHLIB_LD_LIBS to the Make rule, not here.
- EXESUFFIX="\${DBGX}.exe"
+ EXESUFFIX=".exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# Link with gcc since ld does not link to default libs like
@@ -3724,16 +4449,16 @@ echo "$as_me: error: ${CC} does not support the -shared option.
-Wl,--out-implib,\$(patsubst %.dll,lib%.dll.a,\$@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
- DLLSUFFIX="\${DBGX}.dll"
- LIBSUFFIX="\${DBGX}.a"
- LIBFLAGSUFFIX="\${DBGX}"
+ DLLSUFFIX=".dll"
+ LIBSUFFIX=".a"
+ LIBFLAGSUFFIX=""
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
- CFLAGS_WARNING="-Wall -Wpointer-arith"
+ CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
@@ -3742,7 +4467,7 @@ echo "$as_me: error: ${CC} does not support the -shared option.
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
*)
- CFLAGS_WARNING="${CFLAGS_WARNING} -Wdeclaration-after-statement"
+ CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers"
;;
esac
@@ -3770,25 +4495,21 @@ echo "$as_me: error: ${CC} does not support the -shared option.
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
- echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5
-echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
;;
arm64|aarch64)
MACHINE="ARM64"
- echo "$as_me:$LINENO: result: Using ARM64 $MACHINE mode" >&5
-echo "${ECHO_T} Using ARM64 $MACHINE mode" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using ARM64 $MACHINE mode" >&5
+printf "%s\n" " Using ARM64 $MACHINE mode" >&6; }
;;
ia64)
MACHINE="IA64"
- echo "$as_me:$LINENO: result: Using IA64 $MACHINE mode" >&5
-echo "${ECHO_T} Using IA64 $MACHINE mode" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using IA64 $MACHINE mode" >&5
+printf "%s\n" " Using IA64 $MACHINE mode" >&6; }
;;
*)
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef _WIN64
@@ -3796,68 +4517,45 @@ cat >>conftest.$ac_ext <<_ACEOF
#endif
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_win_64bit=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_win_64bit=no
+else $as_nop
+ tcl_win_64bit=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
if test "$tcl_win_64bit" = "yes" ; then
do64bit=amd64
MACHINE="AMD64"
- echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5
-echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
fi
;;
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
- echo "$as_me:$LINENO: result: using static flags" >&5
-echo "${ECHO_T}using static flags" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
+printf "%s\n" "using static flags" >&6; }
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
- EXESUFFIX="s\${DBGX}.exe"
+ EXESUFFIX="s.exe"
else
# dynamic
- echo "$as_me:$LINENO: result: using shared flags" >&5
-echo "${ECHO_T}using shared flags" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
+printf "%s\n" "using shared flags" >&6; }
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
- EXESUFFIX="\${DBGX}.exe"
+ EXESUFFIX=".exe"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
@@ -3869,9 +4567,9 @@ echo "${ECHO_T}using shared flags" >&6
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
- DLLSUFFIX="\${DBGX}.dll"
- LIBSUFFIX="\${DBGX}.lib"
- LIBFLAGSUFFIX="\${DBGX}"
+ DLLSUFFIX=".dll"
+ LIBSUFFIX=".lib"
+ LIBFLAGSUFFIX=""
if test "$do64bit" != "no" ; then
case "$do64bit" in
@@ -3885,8 +4583,8 @@ echo "${ECHO_T}using shared flags" >&6
MACHINE="IA64"
;;
esac
- echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5
-echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
fi
LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
@@ -3919,111 +4617,7 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
LINKBIN="link"
fi
- if test "$doWince" != "no" ; then
- # Set defaults for common evc4/PPC2003 setup
- # Currently Tcl requires 300+, possibly 420+ for sockets
- CEVERSION=420; # could be 211 300 301 400 420 ...
- TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ...
- ARCH=ARM; # could be ARM MIPS X86EM ...
- PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002"
- if test "$doWince" != "yes"; then
- # If !yes then the user specified something
- # Reset ARCH to allow user to skip specifying it
- ARCH=
- eval `echo $doWince | awk -F "," '{ \
- if (length($1)) { printf "CEVERSION=\"%s\"\n", $1; \
- if ($1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \
- if (length($2)) { printf "TARGETCPU=\"%s\"\n", toupper($2) }; \
- if (length($3)) { printf "ARCH=\"%s\"\n", toupper($3) }; \
- if (length($4)) { printf "PLATFORM=\"%s\"\n", $4 }; \
- }'`
- if test "x${ARCH}" = "x" ; then
- ARCH=$TARGETCPU;
- fi
- fi
- OSVERSION=WCE$CEVERSION;
- if test "x${WCEROOT}" = "x" ; then
- WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0"
- if test ! -d "${WCEROOT}" ; then
- WCEROOT="C:/Program Files/Microsoft eMbedded Tools"
- fi
- fi
- if test "x${SDKROOT}" = "x" ; then
- SDKROOT="C:/Program Files/Windows CE Tools"
- if test ! -d "${SDKROOT}" ; then
- SDKROOT="C:/Windows CE Tools"
- fi
- fi
- # The space-based-path will work for the Makefile, but will
- # not work if AC_TRY_COMPILE is called.
- WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'`
- SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'`
- CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'`
- if test ! -d "${CELIB_DIR}/inc"; then
- { { echo "$as_me:$LINENO: error: Invalid celib directory \"${CELIB_DIR}\"" >&5
-echo "$as_me: error: Invalid celib directory \"${CELIB_DIR}\"" >&2;}
- { (exit 1); exit 1; }; }
- fi
- if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\
- -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then
- { { echo "$as_me:$LINENO: error: could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" >&5
-echo "$as_me: error: could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" >&2;}
- { (exit 1); exit 1; }; }
- else
- CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include"
- if test -d "${CEINCLUDE}/${TARGETCPU}" ; then
- CEINCLUDE="${CEINCLUDE}/${TARGETCPU}"
- fi
- CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"
- fi
- fi
-
- if test "$doWince" != "no" ; then
- CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin"
- if test "${TARGETCPU}" = "X86"; then
- CC="${CEBINROOT}/cl.exe"
- else
- CC="${CEBINROOT}/cl${ARCH}.exe"
- fi
- CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\""
- RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\""
- arch=`echo ${ARCH} | awk '{print tolower($0)}'`
- defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS"
- for i in $defs ; do
- cat >>confdefs.h <<_ACEOF
-#define $i 1
-_ACEOF
-
- done
-# if test "${ARCH}" = "X86EM"; then
-# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION)
-# fi
- cat >>confdefs.h <<_ACEOF
-#define _WIN32_WCE $CEVERSION
-_ACEOF
-
- cat >>confdefs.h <<_ACEOF
-#define UNDER_CE $CEVERSION
-_ACEOF
-
- CFLAGS_DEBUG="-nologo -Zi -Od"
- CFLAGS_OPTIMIZE="-nologo -O2"
- lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'`
- lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo"
- LINKBIN="\"${CEBINROOT}/link.exe\""
-
- if test "${CEVERSION}" -lt 400 ; then
- LIBS="coredll.lib corelibc.lib winsock.lib"
- else
- LIBS="coredll.lib corelibc.lib ws2.lib"
- fi
- # celib currently stuck at wce300 status
- #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib"
- LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\""
- LIBS_GUI="commctrl.lib commdlg.lib"
- else
- LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib"
- fi
+ LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib"
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
SHLIB_LD_LIBS='${LIBS}'
@@ -4054,7 +4648,7 @@ _ACEOF
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
- if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then
+ if test "${TARGETCPU}" != "X86"; then
LDFLAGS_CONSOLE="-link ${lflags}"
LDFLAGS_WINDOW=${LDFLAGS_CONSOLE}
else
@@ -4064,26 +4658,65 @@ _ACEOF
fi
if test "$do64bit" != "no" ; then
- cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_DO64BIT 1
-_ACEOF
+ printf "%s\n" "#define TCL_CFG_DO64BIT 1" >>confdefs.h
fi
if test "${GCC}" = "yes" ; then
- echo "$as_me:$LINENO: checking for SEH support in compiler" >&5
-echo $ECHO_N "checking for SEH support in compiler... $ECHO_C" >&6
-if test "${tcl_cv_seh+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- if test "$cross_compiling" = yes; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for SEH support in compiler" >&5
+printf %s "checking for SEH support in compiler... " >&6; }
+if test ${tcl_cv_seh+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test "$cross_compiling" = yes
+then :
tcl_cv_seh=no
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+else $as_nop
+
+# ac_fn_c_try_run LINENO
+# ----------------------
+# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that
+# executables *can* be run.
+ac_fn_c_try_run ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if { { ac_try="$ac_link"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'
+ { { case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
+printf "%s\n" "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }
+then :
+ ac_retval=0
+else $as_nop
+ printf "%s\n" "$as_me: program exited with status $ac_status" >&5
+ printf "%s\n" "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_retval=$ac_status
+fi
+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+ as_fn_set_status $ac_retval
+
+} # ac_fn_c_try_run
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
@@ -4102,37 +4735,23 @@ cat >>conftest.$ac_ext <<_ACEOF
}
_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_run "$LINENO"
+then :
tcl_cv_seh=yes
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-tcl_cv_seh=no
+else $as_nop
+ tcl_cv_seh=no
fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
+
fi
-echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5
-echo "${ECHO_T}$tcl_cv_seh" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_seh" >&5
+printf "%s\n" "$tcl_cv_seh" >&6; }
if test "$tcl_cv_seh" = "no" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_SEH 1
-_ACEOF
+printf "%s\n" "#define HAVE_NO_SEH 1" >>confdefs.h
fi
@@ -4142,16 +4761,13 @@ _ACEOF
# with Cygwin's version as of 2002-04-10, define it to be int,
# sufficient for getting the current code to work.
#
- echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5
-echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6
-if test "${tcl_cv_eh_disposition+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for EXCEPTION_DISPOSITION support in include files" >&5
+printf %s "checking for EXCEPTION_DISPOSITION support in include files... " >&6; }
+if test ${tcl_cv_eh_disposition+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
# define WIN32_LEAN_AND_MEAN
@@ -4159,7 +4775,7 @@ cat >>conftest.$ac_ext <<_ACEOF
# undef WIN32_LEAN_AND_MEAN
int
-main ()
+main (void)
{
EXCEPTION_DISPOSITION x;
@@ -4168,45 +4784,20 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_eh_disposition=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_eh_disposition=no
+else $as_nop
+ tcl_cv_eh_disposition=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5
-echo "${ECHO_T}$tcl_cv_eh_disposition" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_eh_disposition" >&5
+printf "%s\n" "$tcl_cv_eh_disposition" >&6; }
if test "$tcl_cv_eh_disposition" = "no" ; then
-cat >>confdefs.h <<\_ACEOF
-#define EXCEPTION_DISPOSITION int
-_ACEOF
+printf "%s\n" "#define EXCEPTION_DISPOSITION int" >>confdefs.h
fi
@@ -4214,16 +4805,13 @@ _ACEOF
# even if VOID has already been #defined. The win32api
# used by mingw and cygwin is known to do this.
- echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5
-echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6
-if test "${tcl_cv_winnt_ignore_void+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for winnt.h that ignores VOID define" >&5
+printf %s "checking for winnt.h that ignores VOID define... " >&6; }
+if test ${tcl_cv_winnt_ignore_void+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define VOID void
@@ -4232,7 +4820,7 @@ cat >>conftest.$ac_ext <<_ACEOF
#undef WIN32_LEAN_AND_MEAN
int
-main ()
+main (void)
{
CHAR c;
@@ -4243,66 +4831,47 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_winnt_ignore_void=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_winnt_ignore_void=no
+else $as_nop
+ tcl_cv_winnt_ignore_void=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5
-echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5
+printf "%s\n" "$tcl_cv_winnt_ignore_void" >&6; }
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_WINNT_IGNORE_VOID 1
-_ACEOF
+printf "%s\n" "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h
fi
+ ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
+if test "x$ac_cv_header_stdbool_h" = xyes
+then :
+
+printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h
+
+fi
+
+
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
- echo "$as_me:$LINENO: checking for cast to union support" >&5
-echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
-if test "${tcl_cv_cast_to_union+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
+printf %s "checking for cast to union support... " >&6; }
+if test ${tcl_cv_cast_to_union+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
-main ()
+main (void)
{
union foo { int i; double d; };
@@ -4312,45 +4881,20 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_cast_to_union=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cast_to_union=no
+else $as_nop
+ tcl_cv_cast_to_union=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
-echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
+printf "%s\n" "$tcl_cv_cast_to_union" >&6; }
if test "$tcl_cv_cast_to_union" = "yes"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_CAST_TO_UNION 1
-_ACEOF
+printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
fi
@@ -4374,423 +4918,324 @@ case ${host_alias} in
esac
#------------------------------------------------------------------------
-# Add stuff for zlib; note that this is mostly done in the makefile now
-# as we just assume that the platform hasn't got a usable z.lib
+# Add stuff for zlib/libtommath; note that this is mostly done in the
+# makefile now as we just assume that the platform hasn't got usable
+# z.lib/tommath.lib
#------------------------------------------------------------------------
-if test "${enable_shared+set}" = "set"; then
+if test "${enable_shared+set}" = "set"
+then :
enableval="$enable_shared"
tcl_ok=$enableval
-else
+else $as_nop
tcl_ok=yes
fi
-
-if test "$tcl_ok" = "yes"; then
+if test "$tcl_ok" = "yes"
+then :
ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
- if test "$do64bit" != "no"; then
+ TOMMATH_DLL_FILE=\${TOMMATH_DLL_FILE}
+
+
+printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
- if test "$do64bit" = "arm64"; then
+ if test "$do64bit" != "no"
+then :
- if test "$GCC" == "yes"; then
+
+printf "%s\n" "#define MP_64BIT 1" >>confdefs.h
+
+ if test "$do64bit" = "arm64"
+then :
+
+ if test "$GCC" == "yes"
+then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a
-else
+
+else $as_nop
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib
+
fi
+else $as_nop
-else
-
- if test "$GCC" == "yes"; then
+ if test "$GCC" == "yes"
+then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a
-else
+
+else $as_nop
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
-
-fi
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib
fi
+fi
-else
+else $as_nop
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win32/tommath.lib
-fi
+fi
-else
+else $as_nop
ZLIB_OBJS=\${ZLIB_OBJS}
+ TOMMATH_OBJS=\${TOMMATH_OBJS}
+
fi
+printf "%s\n" "#define HAVE_ZLIB 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_ZLIB 1
-_ACEOF
+ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "
+#include <stdint.h>
-# On IRIX 5.3, sys/types and inttypes.h are conflicting.
+"
+if test "x$ac_cv_type_intptr_t" = xyes
+then :
+printf "%s\n" "#define HAVE_INTPTR_T 1" >>confdefs.h
+fi
+ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "
+#include <stdint.h>
+"
+if test "x$ac_cv_type_uintptr_t" = xyes
+then :
+printf "%s\n" "#define HAVE_UINTPTR_T 1" >>confdefs.h
+fi
-for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \
- inttypes.h stdint.h unistd.h
-do
-as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
-echo "$as_me:$LINENO: checking for $ac_header" >&5
-echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
-if eval "test \"\${$as_ac_Header+set}\" = set"; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
+#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+# Check whether --enable-zipfs was given.
+if test ${enable_zipfs+y}
+then :
+ enableval=$enable_zipfs; tcl_ok=$enableval
+else $as_nop
+ tcl_ok=yes
+fi
-#include <$ac_header>
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- eval "$as_ac_Header=yes"
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+if test "$tcl_ok" = "yes" ; then
+ #
+ # Find a native compiler
+ #
+ # Put a plausible default for CC_FOR_BUILD in Makefile.
+if test -z "$CC_FOR_BUILD"; then
+ if test "x$cross_compiling" = "xno"; then
+ CC_FOR_BUILD='$(CC)'
+ else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
+printf %s "checking for gcc... " >&6; }
+ if test ${ac_cv_path_cc+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/gcc 2> /dev/null` \
+ `ls -r $dir/gcc 2> /dev/null` ; do
+ if test x"$ac_cv_path_cc" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_cc=$j
+ break
+ fi
+ fi
+ done
+ done
-eval "$as_ac_Header=no"
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
-echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
- cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
-_ACEOF
+ fi
fi
-done
-
-
-echo "$as_me:$LINENO: checking for intptr_t" >&5
-echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6
-if test "${ac_cv_type_intptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((intptr_t *) 0)
- return 0;
-if (sizeof (intptr_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_intptr_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+# Also set EXEEXT_FOR_BUILD.
+if test "x$cross_compiling" = "xno"; then
+ EXEEXT_FOR_BUILD='$(EXEEXT)'
+ OBJEXT_FOR_BUILD='$(OBJEXT)'
+else
+ OBJEXT_FOR_BUILD='.no'
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
+printf %s "checking for build system executable suffix... " >&6; }
+if test ${bfd_cv_build_exeext+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ rm -f conftest*
+ echo 'int main () { return 0; }' > conftest.c
+ bfd_cv_build_exeext=
+ ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
+ for file in conftest.*; do
+ case $file in
+ *.c | *.o | *.obj | *.ilk | *.pdb) ;;
+ *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
+ esac
+ done
+ rm -f conftest*
+ test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
+printf "%s\n" "$bfd_cv_build_exeext" >&6; }
+ EXEEXT_FOR_BUILD=""
+ test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
+fi
+
+ #
+ # Find a native zip implementation
+ #
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
+printf %s "checking for tclsh... " >&6; }
+
+ if test ${ac_cv_path_tclsh+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/tclsh[8-9]*.exe 2> /dev/null` \
+ `ls -r $dir/tclsh* 2> /dev/null` ; do
+ if test x"$ac_cv_path_tclsh" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_tclsh=$j
+ break
+ fi
+ fi
+ done
+ done
-ac_cv_type_intptr_t=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_intptr_t" >&5
-echo "${ECHO_T}$ac_cv_type_intptr_t" >&6
-if test $ac_cv_type_intptr_t = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_INTPTR_T 1
-_ACEOF
+ if test -f "$ac_cv_path_tclsh" ; then
+ TCLSH_PROG="$ac_cv_path_tclsh"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
+printf "%s\n" "$TCLSH_PROG" >&6; }
+ else
+ # It is not an error if an installed version of Tcl can't be located.
+ TCLSH_PROG=""
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
+printf "%s\n" "No tclsh found on PATH" >&6; }
+ fi
-else
- echo "$as_me:$LINENO: checking for pointer-size signed integer type" >&5
-echo $ECHO_N "checking for pointer-size signed integer type... $ECHO_C" >&6
-if test "${tcl_cv_intptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- for tcl_cv_intptr_t in "int" "long" "long long" none; do
- if test "$tcl_cv_intptr_t" != none; then
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))];
-test_array [0] = 0
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_ok=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- test "$tcl_ok" = yes && break; fi
+ ZIP_PROG=""
+ ZIP_PROG_OPTIONS=""
+ ZIP_PROG_VFSSEARCH=""
+ ZIP_INSTALL_OBJS=""
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
+printf %s "checking for zip... " >&6; }
+ if test ${ac_cv_path_zip+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/zip 2> /dev/null` \
+ `ls -r $dir/zip 2> /dev/null` ; do
+ if test x"$ac_cv_path_zip" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_zip=$j
+ break
+ fi
+ fi
+ done
done
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_intptr_t" >&5
-echo "${ECHO_T}$tcl_cv_intptr_t" >&6
- if test "$tcl_cv_intptr_t" != none; then
-cat >>confdefs.h <<_ACEOF
-#define intptr_t $tcl_cv_intptr_t
-_ACEOF
+fi
+ if test -f "$ac_cv_path_zip" ; then
+ ZIP_PROG="$ac_cv_path_zip"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
+printf "%s\n" "$ZIP_PROG" >&6; }
+ ZIP_PROG_OPTIONS="-rq"
+ ZIP_PROG_VFSSEARCH="*"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
+printf "%s\n" "Found INFO Zip in environment" >&6; }
+ # Use standard arguments for zip
+ else
+ # It is not an error if an installed version of Zip can't be located.
+ # We can use the locally distributed minizip instead
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG_OPTIONS="-o -r"
+ ZIP_PROG_VFSSEARCH="*"
+ ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH building minizip" >&5
+printf "%s\n" "No zip found on PATH building minizip" >&6; }
fi
-fi
-echo "$as_me:$LINENO: checking for uintptr_t" >&5
-echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6
-if test "${ac_cv_type_uintptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-if ((uintptr_t *) 0)
- return 0;
-if (sizeof (uintptr_t))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- ac_cv_type_uintptr_t=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_type_uintptr_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-fi
-echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5
-echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6
-if test $ac_cv_type_uintptr_t = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_UINTPTR_T 1
-_ACEOF
+ ZIPFS_BUILD=1
+ TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip
else
+ ZIPFS_BUILD=0
+ TCL_ZIP_FILE=
+fi
+# Do checking message here to not mess up interleaved configure output
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
+printf %s "checking for building with zipfs... " >&6; }
+if test "${ZIPFS_BUILD}" = 1; then
+ if test "${SHARED_BUILD}" = 0; then
+ ZIPFS_BUILD=2;
- echo "$as_me:$LINENO: checking for pointer-size unsigned integer type" >&5
-echo $ECHO_N "checking for pointer-size unsigned integer type... $ECHO_C" >&6
-if test "${tcl_cv_uintptr_t+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
+printf "%s\n" "#define ZIPFS_BUILD 2" >>confdefs.h
- for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \
- none; do
- if test "$tcl_cv_uintptr_t" != none; then
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))];
-test_array [0] = 0
+ else
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
- tcl_ok=yes
+printf "%s\n" "#define ZIPFS_BUILD 1" >>confdefs.h
+\
+ fi
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
- test "$tcl_ok" = yes && break; fi
- done
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+INSTALL_LIBRARIES=install-libraries
+INSTALL_MSGS=install-msgs
fi
-echo "$as_me:$LINENO: result: $tcl_cv_uintptr_t" >&5
-echo "${ECHO_T}$tcl_cv_uintptr_t" >&6
- if test "$tcl_cv_uintptr_t" != none; then
-cat >>confdefs.h <<_ACEOF
-#define uintptr_t $tcl_cv_uintptr_t
-_ACEOF
- fi
-fi
+
#--------------------------------------------------------------------
@@ -4801,16 +5246,13 @@ fi
# missing from winbase.h. This is known to be
# a problem with VC++ 5.2.
-echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
-echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
-if test "${tcl_cv_findex_enums+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
+printf %s "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; }
+if test ${tcl_cv_findex_enums+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
@@ -4818,7 +5260,7 @@ cat >>conftest.$ac_ext <<_ACEOF
#undef WIN32_LEAN_AND_MEAN
int
-main ()
+main (void)
{
FINDEX_INFO_LEVELS i;
@@ -4828,60 +5270,32 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_findex_enums=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_findex_enums=no
+else $as_nop
+ tcl_cv_findex_enums=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
-echo "${ECHO_T}$tcl_cv_findex_enums" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5
+printf "%s\n" "$tcl_cv_findex_enums" >&6; }
if test "$tcl_cv_findex_enums" = "no"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_FINDEX_ENUMS 1
-_ACEOF
+printf "%s\n" "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h
fi
# See if the compiler supports intrinsics.
-echo "$as_me:$LINENO: checking for intrinsics support in compiler" >&5
-echo $ECHO_N "checking for intrinsics support in compiler... $ECHO_C" >&6
-if test "${tcl_cv_intrinsics+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for intrinsics support in compiler" >&5
+printf %s "checking for intrinsics support in compiler... " >&6; }
+if test ${tcl_cv_intrinsics+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
@@ -4890,7 +5304,7 @@ cat >>conftest.$ac_ext <<_ACEOF
#include <intrin.h>
int
-main ()
+main (void)
{
__cpuidex(0,0,0);
@@ -4899,112 +5313,59 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
- (eval $ac_link) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest$ac_exeext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_link "$LINENO"
+then :
tcl_cv_intrinsics=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_intrinsics=no
+else $as_nop
+ tcl_cv_intrinsics=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+ conftest$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_intrinsics" >&5
-echo "${ECHO_T}$tcl_cv_intrinsics" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intrinsics" >&5
+printf "%s\n" "$tcl_cv_intrinsics" >&6; }
if test "$tcl_cv_intrinsics" = "yes"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_INTRIN_H 1
-_ACEOF
+printf "%s\n" "#define HAVE_INTRIN_H 1" >>confdefs.h
fi
# See if the <wspiapi.h> header file is present
-echo "$as_me:$LINENO: checking for wspiapi.h" >&5
-echo $ECHO_N "checking for wspiapi.h... $ECHO_C" >&6
-if test "${tcl_cv_wspiapi_h+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for wspiapi.h" >&5
+printf %s "checking for wspiapi.h... " >&6; }
+if test ${tcl_cv_wspiapi_h+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <wspiapi.h>
int
-main ()
+main (void)
{
;
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_wspiapi_h=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_wspiapi_h=no
+else $as_nop
+ tcl_cv_wspiapi_h=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_wspiapi_h" >&5
-echo "${ECHO_T}$tcl_cv_wspiapi_h" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_wspiapi_h" >&5
+printf "%s\n" "$tcl_cv_wspiapi_h" >&6; }
if test "$tcl_cv_wspiapi_h" = "yes"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_WSPIAPI_H 1
-_ACEOF
+printf "%s\n" "#define HAVE_WSPIAPI_H 1" >>confdefs.h
fi
@@ -5012,16 +5373,13 @@ fi
# missing from winbase.h. This is known to be
# a problem with VC++ 5.2.
-echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
-echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
-if test "${tcl_cv_findex_enums+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
+printf %s "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; }
+if test ${tcl_cv_findex_enums+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
@@ -5029,7 +5387,7 @@ cat >>conftest.$ac_ext <<_ACEOF
#undef WIN32_LEAN_AND_MEAN
int
-main ()
+main (void)
{
FINDEX_INFO_LEVELS i;
@@ -5039,45 +5397,20 @@ main ()
return 0;
}
_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
- (eval $ac_compile) 2>conftest.er1
- ac_status=$?
- grep -v '^ *+' conftest.er1 >conftest.err
- rm -f conftest.er1
- cat conftest.err >&5
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); } &&
- { ac_try='test -z "$ac_c_werror_flag"
- || test ! -s conftest.err'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; } &&
- { ac_try='test -s conftest.$ac_objext'
- { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
- (eval $ac_try) 2>&5
- ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; }; then
+if ac_fn_c_try_compile "$LINENO"
+then :
tcl_cv_findex_enums=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_findex_enums=no
+else $as_nop
+ tcl_cv_findex_enums=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
-echo "${ECHO_T}$tcl_cv_findex_enums" >&6
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5
+printf "%s\n" "$tcl_cv_findex_enums" >&6; }
if test "$tcl_cv_findex_enums" = "no"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_FINDEX_ENUMS 1
-_ACEOF
+printf "%s\n" "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h
fi
@@ -5088,39 +5421,34 @@ fi
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for build with symbols" >&5
-echo $ECHO_N "checking for build with symbols... $ECHO_C" >&6
- # Check whether --enable-symbols or --disable-symbols was given.
-if test "${enable_symbols+set}" = set; then
- enableval="$enable_symbols"
- tcl_ok=$enableval
-else
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
+printf %s "checking for build with symbols... " >&6; }
+ # Check whether --enable-symbols was given.
+if test ${enable_symbols+y}
+then :
+ enableval=$enable_symbols; tcl_ok=$enableval
+else $as_nop
tcl_ok=no
-fi;
+fi
+
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
- DBGX=""
-cat >>confdefs.h <<\_ACEOF
-#define NDEBUG 1
-_ACEOF
+printf "%s\n" "#define NDEBUG 1" >>confdefs.h
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
- cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_OPTIMIZED 1
-_ACEOF
+ printf "%s\n" "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- DBGX=g
if test "$tcl_ok" = "yes"; then
- echo "$as_me:$LINENO: result: yes (standard debugging)" >&5
-echo "${ECHO_T}yes (standard debugging)" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
+printf "%s\n" "yes (standard debugging)" >&6; }
fi
fi
@@ -5128,52 +5456,320 @@ echo "${ECHO_T}yes (standard debugging)" >&6
if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_MEM_DEBUG 1
-_ACEOF
+printf "%s\n" "#define TCL_MEM_DEBUG 1" >>confdefs.h
fi
if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_COMPILE_DEBUG 1
-_ACEOF
+printf "%s\n" "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define TCL_COMPILE_STATS 1
-_ACEOF
+printf "%s\n" "#define TCL_COMPILE_STATS 1" >>confdefs.h
fi
if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
if test "$tcl_ok" = "all"; then
- echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5
-echo "${ECHO_T}enabled symbols mem compile debugging" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
+printf "%s\n" "enabled symbols mem compile debugging" >&6; }
else
- echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5
-echo "${ECHO_T}enabled $tcl_ok debugging" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
+printf "%s\n" "enabled $tcl_ok debugging" >&6; }
fi
fi
-TCL_DBGX=${DBGX}
-
#--------------------------------------------------------------------
# Embed the manifest if we can determine how
#--------------------------------------------------------------------
+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
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
+printf %s "checking how to run the C preprocessor... " >&6; }
+# On Suns, sometimes $CPP names a directory.
+if test -n "$CPP" && test -d "$CPP"; then
+ CPP=
+fi
+if test -z "$CPP"; then
+ if test ${ac_cv_prog_CPP+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ # Double quotes because $CC needs to be expanded
+ for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp
+ do
+ ac_preproc_ok=false
+for ac_c_preproc_warn_flag in '' yes
+do
+ # Use a header file that comes with gcc, so configuring glibc
+ # with a fresh cross-compiler works.
+ # On the NeXT, cc -E runs the code through the compiler's parser,
+ # not just through cpp. "Syntax error" is here to catch this case.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <limits.h>
+ Syntax error
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"
+then :
+
+else $as_nop
+ # Broken: fails on valid input.
+continue
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+ # OK, works on sane cases. Now check whether nonexistent headers
+ # can be detected and how.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <ac_nonexistent.h>
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"
+then :
+ # Broken: success on invalid input.
+continue
+else $as_nop
+ # Passes both tests.
+ac_preproc_ok=:
+break
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+done
+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
+rm -f conftest.i conftest.err conftest.$ac_ext
+if $ac_preproc_ok
+then :
+ break
+fi
+
+ done
+ ac_cv_prog_CPP=$CPP
+
+fi
+ CPP=$ac_cv_prog_CPP
+else
+ ac_cv_prog_CPP=$CPP
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
+printf "%s\n" "$CPP" >&6; }
+ac_preproc_ok=false
+for ac_c_preproc_warn_flag in '' yes
+do
+ # Use a header file that comes with gcc, so configuring glibc
+ # with a fresh cross-compiler works.
+ # On the NeXT, cc -E runs the code through the compiler's parser,
+ # not just through cpp. "Syntax error" is here to catch this case.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <limits.h>
+ Syntax error
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"
+then :
+
+else $as_nop
+ # Broken: fails on valid input.
+continue
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+ # OK, works on sane cases. Now check whether nonexistent headers
+ # can be detected and how.
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <ac_nonexistent.h>
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"
+then :
+ # Broken: success on invalid input.
+continue
+else $as_nop
+ # Passes both tests.
+ac_preproc_ok=:
+break
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+
+done
+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
+rm -f conftest.i conftest.err conftest.$ac_ext
+if $ac_preproc_ok
+then :
+
+else $as_nop
+ { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "C preprocessor \"$CPP\" fails sanity check
+See \`config.log' for more details" "$LINENO" 5; }
+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
+
+
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
+printf %s "checking for grep that handles long lines and -e... " >&6; }
+if test ${ac_cv_path_GREP+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if test -z "$GREP"; then
+ ac_path_GREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_prog in grep ggrep
+ do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_GREP="$as_dir$ac_prog$ac_exec_ext"
+ as_fn_executable_p "$ac_path_GREP" || continue
+# Check for GNU ac_path_GREP and select it if it is found.
+ # Check for GNU $ac_path_GREP
+case `"$ac_path_GREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;
+*)
+ ac_count=0
+ printf %s 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ printf "%s\n" 'GREP' >> "conftest.nl"
+ "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_GREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_GREP="$ac_path_GREP"
+ ac_path_GREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+ $ac_path_GREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_GREP"; then
+ as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
+else
+ ac_cv_path_GREP=$GREP
+fi
+
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
+printf "%s\n" "$ac_cv_path_GREP" >&6; }
+ GREP="$ac_cv_path_GREP"
- echo "$as_me:$LINENO: checking whether to embed manifest" >&5
-echo $ECHO_N "checking whether to embed manifest... $ECHO_C" >&6
- # Check whether --enable-embedded-manifest or --disable-embedded-manifest was given.
-if test "${enable_embedded_manifest+set}" = set; then
- enableval="$enable_embedded_manifest"
- embed_ok=$enableval
+
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
+printf %s "checking for egrep... " >&6; }
+if test ${ac_cv_path_EGREP+y}
+then :
+ printf %s "(cached) " >&6
+else $as_nop
+ if echo a | $GREP -E '(a|b)' >/dev/null 2>&1
+ then ac_cv_path_EGREP="$GREP -E"
+ else
+ if test -z "$EGREP"; then
+ ac_path_EGREP_found=false
+ # Loop through the user's path and test for each of PROGNAME-LIST
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
+do
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ for ac_prog in egrep
+ do
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext"
+ as_fn_executable_p "$ac_path_EGREP" || continue
+# Check for GNU ac_path_EGREP and select it if it is found.
+ # Check for GNU $ac_path_EGREP
+case `"$ac_path_EGREP" --version 2>&1` in
+*GNU*)
+ ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;
+*)
+ ac_count=0
+ printf %s 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ printf "%s\n" 'EGREP' >> "conftest.nl"
+ "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
+ diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
+ as_fn_arith $ac_count + 1 && ac_count=$as_val
+ if test $ac_count -gt ${ac_path_EGREP_max-0}; then
+ # Best one so far, save it but keep looking for a better one
+ ac_cv_path_EGREP="$ac_path_EGREP"
+ ac_path_EGREP_max=$ac_count
+ fi
+ # 10*(2^10) chars as input seems more than enough
+ test $ac_count -gt 10 && break
+ done
+ rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
+esac
+
+ $ac_path_EGREP_found && break 3
+ done
+ done
+ done
+IFS=$as_save_IFS
+ if test -z "$ac_cv_path_EGREP"; then
+ as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
+ fi
else
+ ac_cv_path_EGREP=$EGREP
+fi
+
+ fi
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
+printf "%s\n" "$ac_cv_path_EGREP" >&6; }
+ EGREP="$ac_cv_path_EGREP"
+
+
+
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to embed manifest" >&5
+printf %s "checking whether to embed manifest... " >&6; }
+ # Check whether --enable-embedded-manifest was given.
+if test ${enable_embedded_manifest+y}
+then :
+ enableval=$enable_embedded_manifest; embed_ok=$enableval
+else $as_nop
embed_ok=yes
-fi;
+fi
+
VC_MANIFEST_EMBED_DLL=
VC_MANIFEST_EMBED_EXE=
@@ -5181,11 +5777,7 @@ fi;
if test "$embed_ok" = "yes" -a "${SHARED_BUILD}" = "1" \
-a "$GCC" != "yes" ; then
# Add the magic to embed the manifest into the dll/exe
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#if defined(_MSC_VER) && _MSC_VER >= 1400
@@ -5194,7 +5786,8 @@ print("manifest needed")
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "manifest needed" >/dev/null 2>&1; then
+ $EGREP "manifest needed" >/dev/null 2>&1
+then :
# Could do a CHECK_PROG for mt, but should always be with MSVC8+
# Could add 'if test -f' check, but manifest should be created
@@ -5210,11 +5803,11 @@ if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
fi
fi
-rm -f conftest*
+rm -rf conftest*
fi
- echo "$as_me:$LINENO: result: $result" >&5
-echo "${ECHO_T}$result" >&6
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $result" >&5
+printf "%s\n" "$result" >&6; }
@@ -5251,11 +5844,6 @@ eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
-eval "DLLSUFFIX=${DLLSUFFIX}"
-eval "LIBPREFIX=${LIBPREFIX}"
-eval "LIBSUFFIX=${LIBSUFFIX}"
-eval "EXESUFFIX=${EXESUFFIX}"
-
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
@@ -5270,17 +5858,9 @@ CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
#--------------------------------------------------------------------
if test ${SHARED_BUILD} = 0 ; then
- if test "${DBGX}" = "g"; then
- RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG"
- else
- RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
- fi
+ RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
else
- if test "${DBGX}" = "g"; then
- RC_DEFINES="${RC_DEFINE} DEBUG"
- else
- RC_DEFINES=""
- fi
+ RC_DEFINES=""
fi
#--------------------------------------------------------------------
@@ -5339,7 +5919,6 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d
-
# win/tcl.m4 doesn't set (CFLAGS)
@@ -5404,7 +5983,7 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d
- ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest"
+ac_config_files="$ac_config_files Makefile tclConfig.sh tclsh.exe.manifest"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
@@ -5424,39 +6003,70 @@ _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.
+# So, we kill variables containing newlines.
# 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.
-{
+(
+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
+ eval ac_val=\$$ac_var
+ case $ac_val in #(
+ *${as_nl}*)
+ case $ac_var in #(
+ *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
+ esac
+ case $ac_var in #(
+ _ | IFS | as_nl) ;; #(
+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
+ *) { eval $ac_var=; unset $ac_var;} ;;
+ esac ;;
+ esac
+ done
+
(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 \).
+ case $as_nl`(ac_space=' '; set) 2>&1` in #(
+ *${as_nl}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"
+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
- esac;
-} |
+ esac |
+ sort
+) |
sed '
+ /^ac_cv_env_/b end
t clear
- : clear
- s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
+ :clear
+ s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/
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
+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
+ :end' >>confcache
+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
+ if test -w "$cache_file"; then
+ if test "x$cache_file" != "x/dev/null"; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
+printf "%s\n" "$as_me: updating cache $cache_file" >&6;}
+ if test ! -f "$cache_file" || test -h "$cache_file"; then
+ cat confcache >"$cache_file"
+ else
+ case $cache_file in #(
+ */* | ?:*)
+ mv -f confcache "$cache_file"$$ &&
+ mv -f "$cache_file"$$ "$cache_file" ;; #(
+ *)
+ mv -f confcache "$cache_file" ;;
+ esac
+ fi
+ fi
else
- echo "not updating unwritable cache $cache_file"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
+printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
@@ -5465,63 +6075,55 @@ 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,
+# take arguments), then branch to the quote section. Otherwise,
# look for a macro that doesn't take arguments.
-cat >confdef2opt.sed <<\_ACEOF
+ac_script='
+:mline
+/\\$/{
+ N
+ s,\\\n,,
+ b mline
+}
t clear
-: clear
-s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
+:clear
+s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
t quote
-s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
+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
+b any
+:quote
+s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g
+s/\[/\\&/g
+s/\]/\\&/g
+s/\$/$$/g
+H
+:any
+${
+ g
+ s/^\n//
+ s/\n/ /g
+ p
+}
+'
+DEFS=`sed -n "$ac_script" confdefs.h`
ac_libobjs=
ac_ltlibobjs=
+U=
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'
+ ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
+ ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"`
+ # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR
+ # will be set to the directory where LIBOBJS objects are built.
+ as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext"
+ as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs
@@ -5529,12 +6131,14 @@ LTLIBOBJS=$ac_ltlibobjs
-: ${CONFIG_STATUS=./config.status}
+: "${CONFIG_STATUS=./config.status}"
+ac_write_fail=0
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
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
+printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;}
+as_write_fail=0
+cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1
#! $SHELL
# Generated by $as_me.
# Run this file to recreate the current configuration.
@@ -5544,81 +6148,236 @@ cat >$CONFIG_STATUS <<_ACEOF
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
+SHELL=\${CONFIG_SHELL-$SHELL}
+export SHELL
+_ASEOF
+cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1
+## -------------------- ##
+## M4sh Initialization. ##
+## -------------------- ##
+
+# Be more Bourne compatible
+DUALCASE=1; export DUALCASE # for MKS sh
+as_nop=:
+if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
+then :
emulate sh
NULLCMD=:
- # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # Pre-4.2 versions of Zsh do 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
+ setopt NO_GLOB_SUBST
+else $as_nop
+ case `(set -o) 2>/dev/null` in #(
+ *posix*) :
+ set -o posix ;; #(
+ *) :
+ ;;
+esac
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
+# Reset variables that may have inherited troublesome values from
+# the environment.
+
+# IFS needs to be set, to space, tab, and newline, in precisely that order.
+# (If _AS_PATH_WALK were called with IFS unset, it would have the
+# side effect of setting IFS to empty, thus disabling word splitting.)
+# Quoting is to prevent editors from complaining about space-tab.
+as_nl='
+'
+export as_nl
+IFS=" "" $as_nl"
+
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
+# Ensure predictable behavior from utilities with locale-dependent output.
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# We cannot yet rely on "unset" to work, but we need these variables
+# to be unset--not just set to an empty or harmless value--now, to
+# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
+# also avoids known problems related to "unset" and subshell syntax
+# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
+for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
+do eval test \${$as_var+y} \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
+
+# Ensure that fds 0, 1, and 2 are open.
+if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
+if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
+if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
+
+# The user is always right.
+if ${PATH_SEPARATOR+false} :; then
+ PATH_SEPARATOR=:
+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
+ PATH_SEPARATOR=';'
+ }
+fi
+
+
+# Find who we are. Look in the path if we contain no directory separator.
+as_myself=
+case $0 in #((
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
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
+ IFS=$as_save_IFS
+ case $as_dir in #(((
+ '') as_dir=./ ;;
+ */) ;;
+ *) as_dir=$as_dir/ ;;
+ esac
+ test -r "$as_dir$0" && as_myself=$as_dir$0 && break
+ done
+IFS=$as_save_IFS
+
+ ;;
+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
+ printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+
+
+# as_fn_error STATUS ERROR [LINENO LOG_FD]
+# ----------------------------------------
+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
+# script with STATUS, using 1 if that was 0.
+as_fn_error ()
+{
+ as_status=$1; test $as_status -eq 0 && as_status=1
+ if test "$4"; then
+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
-done
+ printf "%s\n" "$as_me: error: $2" >&2
+ as_fn_exit $as_status
+} # as_fn_error
+
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
+
+# as_fn_set_status STATUS
+# -----------------------
+# Set $? to STATUS, without forking.
+as_fn_set_status ()
+{
+ return $1
+} # as_fn_set_status
+
+# as_fn_exit STATUS
+# -----------------
+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
+as_fn_exit ()
+{
+ set +e
+ as_fn_set_status $1
+ exit $1
+} # as_fn_exit
+
+# as_fn_unset VAR
+# ---------------
+# Portably unset VAR.
+as_fn_unset ()
+{
+ { eval $1=; unset $1;}
+}
+as_unset=as_fn_unset
+
+# as_fn_append VAR VALUE
+# ----------------------
+# Append the text in VALUE to the end of the definition contained in VAR. Take
+# advantage of any shell optimizations that allow amortized linear growth over
+# repeated appends, instead of the typical quadratic growth present in naive
+# implementations.
+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
+then :
+ eval 'as_fn_append ()
+ {
+ eval $1+=\$2
+ }'
+else $as_nop
+ as_fn_append ()
+ {
+ eval $1=\$$1\$2
+ }
+fi # as_fn_append
+
+# as_fn_arith ARG...
+# ------------------
+# Perform arithmetic evaluation on the ARGs, and store the result in the
+# global $as_val. Take advantage of shells that can avoid forks. The arguments
+# must be portable across $(()) and expr.
+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
+then :
+ eval 'as_fn_arith ()
+ {
+ as_val=$(( $* ))
+ }'
+else $as_nop
+ as_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+
+if expr a : '\(a\)' >/dev/null 2>&1 &&
+ test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
-if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
+if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
+if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
+ as_dirname=dirname
+else
+ as_dirname=false
+fi
-# Name of the executable.
-as_me=`$as_basename "$0" ||
+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'`
+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" 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'
@@ -5626,148 +6385,121 @@ 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= ;;
+# Determine whether it's possible to make 'echo' print without a newline.
+# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
+# for compatibility with existing Makefiles.
+ECHO_C= ECHO_N= ECHO_T=
+case `echo -n x` in #(((((
+-n*)
+ case `echo 'xy\c'` in
+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.
+ xy) ECHO_C='\c';;
+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
+ ECHO_T=' ';;
+ esac;;
+*)
+ ECHO_N='-n';;
esac
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
+# For backward compatibility with old third-party macros, we provide
+# the shell variables $as_echo and $as_echo_n. New code should use
+# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
+as_echo='printf %s\n'
+as_echo_n='printf %s'
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
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
+else
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
+fi
+if (echo >conf$$.file) 2>/dev/null; then
+ if ln -s conf$$.file conf$$ 2>/dev/null; then
as_ln_s='ln -s'
+ # ... but there are two gotchas:
+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
+ # In both cases, we have to default to `cp -pR'.
+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
+ as_ln_s='cp -pR'
+ elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+ else
+ as_ln_s='cp -pR'
fi
-elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
-rm -f conf$$ conf$$.exe conf$$.file
+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
+rmdir conf$$.dir 2>/dev/null
+
+# as_fn_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
+
+ case $as_dir in #(
+ -*) as_dir=./$as_dir;;
+ esac
+ test -d "$as_dir" || eval $as_mkdir_p || {
+ as_dirs=
+ while :; do
+ case $as_dir in #(
+ *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
+ *) as_qdir=$as_dir;;
+ esac
+ as_dirs="'$as_qdir' $as_dirs"
+ as_dir=`$as_dirname -- "$as_dir" ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ test -d "$as_dir" && break
+ done
+ test -z "$as_dirs" || eval "mkdir $as_dirs"
+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
+
+
+} # as_fn_mkdir_p
if mkdir -p . 2>/dev/null; then
- as_mkdir_p=:
+ as_mkdir_p='mkdir -p "$as_dir"'
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
-as_executable_p="test -f"
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# 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'"
@@ -5776,31 +6508,20 @@ as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
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
+## ----------------------------------- ##
+## Main body of $CONFIG_STATUS script. ##
+## ----------------------------------- ##
+_ASEOF
+test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1
+
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# Save the log message, 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 tcl $as_me 8.6, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+# values after options handling.
+ac_log="
+This file was extended by tcl $as_me 8.7, which was
+generated by GNU Autoconf 2.71. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
@@ -5808,124 +6529,118 @@ generated by GNU Autoconf 2.59. Invocation command line was
CONFIG_COMMANDS = $CONFIG_COMMANDS
$ $0 $@
-_CSEOF
-echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5
-echo >&5
+on `(hostname || uname -n) 2>/dev/null | sed 1q`
+"
+
_ACEOF
-# Files that config.status was made for.
-if test -n "$ac_config_files"; then
- echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS
-fi
+case $ac_config_files in *"
+"*) set x $ac_config_files; shift; ac_config_files=$*;;
+esac
-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_write_fail=1
+# Files that config.status was made for.
+config_files="$ac_config_files"
-cat >>$CONFIG_STATUS <<\_ACEOF
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
ac_cs_usage="\
-\`$as_me' instantiates files from templates according to the
-current configuration.
+\`$as_me' instantiates files and other configuration actions
+from templates according to the current configuration. Unless the files
+and actions are specified as TAGs, all are instantiated by default.
-Usage: $0 [OPTIONS] [FILE]...
+Usage: $0 [OPTION]... [TAG]...
-h, --help print this help, then exit
- -V, --version print version number, then exit
- -q, --quiet do not print progress messages
+ -V, --version print version number and configuration settings, then exit
+ --config print configuration, then exit
+ -q, --quiet, --silent
+ 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
+ --file=FILE[:TEMPLATE]
+ instantiate the configuration file FILE
Configuration files:
$config_files
-Report bugs to <bug-autoconf@gnu.org>."
-_ACEOF
+Report bugs to the package provider."
-cat >>$CONFIG_STATUS <<_ACEOF
+_ACEOF
+ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"`
+ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"`
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_cs_config='$ac_cs_config_escaped'
ac_cs_version="\\
-tcl config.status 8.6
-configured by $0, generated by GNU Autoconf 2.59,
- with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"
+tcl config.status 8.7
+configured by $0, generated by GNU Autoconf 2.71,
+ with options \\"\$ac_cs_config\\"
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2021 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
+
+ac_pwd='$ac_pwd'
+srcdir='$srcdir'
+test -n "\$AWK" || AWK=awk
_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.
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# The default lists apply if the user does not specify any file.
ac_need_defaults=:
while test $# != 0
do
case $1 in
- --*=*)
- ac_option=`expr "x$1" : 'x\([^=]*\)='`
- ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'`
+ --*=?*)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
+ ac_shift=:
+ ;;
+ --*=)
+ ac_option=`expr "X$1" : 'X\([^=]*\)='`
+ ac_optarg=
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 )
+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )
+ printf "%s\n" "$ac_cs_version"; exit ;;
+ --config | --confi | --conf | --con | --co | --c )
+ printf "%s\n" "$ac_cs_config"; exit ;;
+ --debug | --debu | --deb | --de | --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"
+ case $ac_optarg in
+ *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ '') as_fn_error $? "missing file argument" ;;
+ esac
+ as_fn_append CONFIG_FILES " '$ac_optarg'"
ac_need_defaults=false;;
+ --he | --h | --help | --hel | -h )
+ printf "%s\n" "$ac_cs_usage"; exit ;;
-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; }; } ;;
+ -*) as_fn_error $? "unrecognized option: \`$1'
+Try \`$0 --help' for more information." ;;
- *) ac_config_targets="$ac_config_targets $1" ;;
+ *) as_fn_append ac_config_targets " $1"
+ ac_need_defaults=false ;;
esac
shift
@@ -5939,458 +6654,463 @@ if $ac_cs_silent; then
fi
_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
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
+ set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+ shift
+ \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6
+ CONFIG_SHELL='$SHELL'
+ export CONFIG_SHELL
+ exec "\$@"
fi
_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+exec 5>>config.log
+{
+ echo
+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
+## Running $as_me. ##
+_ASBOX
+ printf "%s\n" "$ac_log"
+} >&5
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
-
-
-cat >>$CONFIG_STATUS <<\_ACEOF
+# Handling of arguments.
for ac_config_target in $ac_config_targets
do
- case "$ac_config_target" in
- # Handling of arguments.
- "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;
- "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;;
- "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;;
- "tclsh.exe.manifest" ) CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;;
- *) { { 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; }; };;
+ case $ac_config_target in
+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;;
+ "tclsh.exe.manifest") CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;;
+
+ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
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
+ test ${CONFIG_FILES+y} || 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,
+# simply because there is no reason against having 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.
+# Hook for its removal unless debugging.
+# Note that there is a small window in which the directory will not be cleaned:
+# after its creation but before its name has been assigned to `$tmp'.
$debug ||
{
- trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0
- trap '{ (exit 1); exit 1; }' 1 2 13 15
+ tmp= ac_tmp=
+ trap 'exit_status=$?
+ : "${ac_tmp:=$tmp}"
+ { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status
+' 0
+ trap 'as_fn_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=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
+ test -d "$tmp"
} ||
{
- tmp=./confstat$$-$RANDOM
- (umask 077 && mkdir $tmp)
-} ||
+ tmp=./conf$$-$RANDOM
+ (umask 077 && mkdir "$tmp")
+} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5
+ac_tmp=$tmp
+
+# Set up the scripts for CONFIG_FILES section.
+# No need to generate them if there are no CONFIG_FILES.
+# This happens for instance with `./config.status config.h'.
+if test -n "$CONFIG_FILES"; then
+
+
+ac_cr=`echo X | tr X '\015'`
+# On cygwin, bash can eat \r inside `` if the user requested igncr.
+# But we know of no other shell where ac_cr would be empty at this
+# point, so we can use a bashism as a fallback.
+if test "x$ac_cr" = x; then
+ eval ac_cr=\$\'\\r\'
+fi
+ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null`
+if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then
+ ac_cs_awk_cr='\\r'
+else
+ ac_cs_awk_cr=$ac_cr
+fi
+
+echo 'BEGIN {' >"$ac_tmp/subs1.awk" &&
+_ACEOF
+
+
+{
+ echo "cat >conf$$subs.awk <<_ACEOF" &&
+ echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' &&
+ echo "_ACEOF"
+} >conf$$subs.sh ||
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'`
+ac_delim='%!_!# '
+for ac_last_try in false false false false false :; do
+ . ./conf$$subs.sh ||
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+
+ ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X`
+ if test $ac_delim_n = $ac_delim_num; then
+ break
+ elif $ac_last_try; then
+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5
+ else
+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
+ fi
+done
+rm -f conf$$subs.sh
+
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK &&
+_ACEOF
+sed -n '
+h
+s/^/S["/; s/!.*/"]=/
+p
+g
+s/^[^!]*!//
+:repl
+t repl
+s/'"$ac_delim"'$//
+t delim
+:nl
+h
+s/\(.\{148\}\)..*/\1/
+t more1
+s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/
+p
+n
+b repl
+:more1
+s/["\\]/\\&/g; s/^/"/; s/$/"\\/
+p
+g
+s/.\{148\}//
+t nl
+:delim
+h
+s/\(.\{148\}\)..*/\1/
+t more2
+s/["\\]/\\&/g; s/^/"/; s/$/"/
+p
+b
+:more2
+s/["\\]/\\&/g; s/^/"/; s/$/"\\/
+p
+g
+s/.\{148\}//
+t delim
+' <conf$$subs.awk | sed '
+/^[^""]/{
+ N
+ s/\n//
+}
+' >>$CONFIG_STATUS || ac_write_fail=1
+rm -f conf$$subs.awk
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+_ACAWK
+cat >>"\$ac_tmp/subs1.awk" <<_ACAWK &&
+ for (key in S) S_is_set[key] = 1
+ FS = ""
+
+}
{
- echo "$me: cannot create a temporary directory in ." >&2
- { (exit 1); exit 1; }
+ line = $ 0
+ nfields = split(line, field, "@")
+ substed = 0
+ len = length(field[1])
+ for (i = 2; i < nfields; i++) {
+ key = field[i]
+ keylen = length(key)
+ if (S_is_set[key]) {
+ value = S[key]
+ line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3)
+ len += length(value) + length(field[++i])
+ substed = 1
+ } else
+ len += 1 + keylen
+ }
+
+ print line
}
+_ACAWK
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then
+ sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g"
+else
+ cat
+fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \
+ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5
_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
+# VPATH may cause trouble with some makes, so we remove sole $(srcdir),
+# ${srcdir} and @srcdir@ entries 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[ ]*=[ ]*/{
+h
+s///
+s/^/:/
+s/[ ]*$/:/
+s/:\$(srcdir):/:/g
+s/:\${srcdir}:/:/g
+s/:@srcdir@:/:/g
+s/^:*//
+s/:*$//
+x
+s/\(=[ ]*\).*/\1/
+G
+s/\n//
+s/^[^=]*=[ ]*$//
+}'
+fi
-#
-# CONFIG_FILES section.
-#
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+fi # test -n "$CONFIG_FILES"
-# 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,@CC@,$CC,;t t
-s,@CFLAGS@,$CFLAGS,;t t
-s,@LDFLAGS@,$LDFLAGS,;t t
-s,@CPPFLAGS@,$CPPFLAGS,;t t
-s,@ac_ct_CC@,$ac_ct_CC,;t t
-s,@EXEEXT@,$EXEEXT,;t t
-s,@OBJEXT@,$OBJEXT,;t t
-s,@CPP@,$CPP,;t t
-s,@EGREP@,$EGREP,;t t
-s,@AR@,$AR,;t t
-s,@ac_ct_AR@,$ac_ct_AR,;t t
-s,@RANLIB@,$RANLIB,;t t
-s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t
-s,@RC@,$RC,;t t
-s,@ac_ct_RC@,$ac_ct_RC,;t t
-s,@SET_MAKE@,$SET_MAKE,;t t
-s,@TCL_THREADS@,$TCL_THREADS,;t t
-s,@CYGPATH@,$CYGPATH,;t t
-s,@CELIB_DIR@,$CELIB_DIR,;t t
-s,@DL_LIBS@,$DL_LIBS,;t t
-s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t
-s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t
-s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t
-s,@CFLAGS_NOLTO@,$CFLAGS_NOLTO,;t t
-s,@ZLIB_DLL_FILE@,$ZLIB_DLL_FILE,;t t
-s,@ZLIB_LIBS@,$ZLIB_LIBS,;t t
-s,@ZLIB_OBJS@,$ZLIB_OBJS,;t t
-s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t
-s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t
-s,@VC_MANIFEST_EMBED_DLL@,$VC_MANIFEST_EMBED_DLL,;t t
-s,@VC_MANIFEST_EMBED_EXE@,$VC_MANIFEST_EMBED_EXE,;t t
-s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t
-s,@MACHINE@,$MACHINE,;t t
-s,@TCL_VERSION@,$TCL_VERSION,;t t
-s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t
-s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t
-s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t
-s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t
-s,@TCL_EXE@,$TCL_EXE,;t t
-s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t
-s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t
-s,@TCL_STATIC_LIB_FILE@,$TCL_STATIC_LIB_FILE,;t t
-s,@TCL_STATIC_LIB_FLAG@,$TCL_STATIC_LIB_FLAG,;t t
-s,@TCL_IMPORT_LIB_FILE@,$TCL_IMPORT_LIB_FILE,;t t
-s,@TCL_IMPORT_LIB_FLAG@,$TCL_IMPORT_LIB_FLAG,;t t
-s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t
-s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t
-s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t
-s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t
-s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t
-s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t
-s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t
-s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t
-s,@TCL_DLL_FILE@,$TCL_DLL_FILE,;t t
-s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t
-s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t
-s,@TCL_DBGX@,$TCL_DBGX,;t t
-s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t
-s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t
-s,@CFG_TCL_EXPORT_FILE_SUFFIX@,$CFG_TCL_EXPORT_FILE_SUFFIX,;t t
-s,@EXTRA_CFLAGS@,$EXTRA_CFLAGS,;t t
-s,@DEPARG@,$DEPARG,;t t
-s,@CC_OBJNAME@,$CC_OBJNAME,;t t
-s,@CC_EXENAME@,$CC_EXENAME,;t t
-s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t
-s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t
-s,@LDFLAGS_CONSOLE@,$LDFLAGS_CONSOLE,;t t
-s,@LDFLAGS_WINDOW@,$LDFLAGS_WINDOW,;t t
-s,@STLIB_LD@,$STLIB_LD,;t t
-s,@SHLIB_LD@,$SHLIB_LD,;t t
-s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t
-s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t
-s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t
-s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t
-s,@LIBS_GUI@,$LIBS_GUI,;t t
-s,@DLLSUFFIX@,$DLLSUFFIX,;t t
-s,@LIBPREFIX@,$LIBPREFIX,;t t
-s,@LIBSUFFIX@,$LIBSUFFIX,;t t
-s,@EXESUFFIX@,$EXESUFFIX,;t t
-s,@LIBRARIES@,$LIBRARIES,;t t
-s,@MAKE_LIB@,$MAKE_LIB,;t t
-s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t
-s,@POST_MAKE_LIB@,$POST_MAKE_LIB,;t t
-s,@MAKE_DLL@,$MAKE_DLL,;t t
-s,@MAKE_EXE@,$MAKE_EXE,;t t
-s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t
-s,@TCL_CC_SEARCH_FLAGS@,$TCL_CC_SEARCH_FLAGS,;t t
-s,@TCL_LD_SEARCH_FLAGS@,$TCL_LD_SEARCH_FLAGS,;t t
-s,@TCL_NEEDS_EXP_FILE@,$TCL_NEEDS_EXP_FILE,;t t
-s,@TCL_BUILD_EXP_FILE@,$TCL_BUILD_EXP_FILE,;t t
-s,@TCL_EXP_FILE@,$TCL_EXP_FILE,;t t
-s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t
-s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t
-s,@TCL_DDE_VERSION@,$TCL_DDE_VERSION,;t t
-s,@TCL_DDE_MAJOR_VERSION@,$TCL_DDE_MAJOR_VERSION,;t t
-s,@TCL_DDE_MINOR_VERSION@,$TCL_DDE_MINOR_VERSION,;t t
-s,@TCL_REG_VERSION@,$TCL_REG_VERSION,;t t
-s,@TCL_REG_MAJOR_VERSION@,$TCL_REG_MAJOR_VERSION,;t t
-s,@TCL_REG_MINOR_VERSION@,$TCL_REG_MINOR_VERSION,;t t
-s,@RC_OUT@,$RC_OUT,;t t
-s,@RC_TYPE@,$RC_TYPE,;t t
-s,@RC_INCLUDE@,$RC_INCLUDE,;t t
-s,@RC_DEFINE@,$RC_DEFINE,;t t
-s,@RC_DEFINES@,$RC_DEFINES,;t t
-s,@RES@,$RES,;t t
-s,@LIBOBJS@,$LIBOBJS,;t t
-s,@LTLIBOBJS@,$LTLIBOBJS,;t t
-CEOF
-_ACEOF
+eval set X " :F $CONFIG_FILES "
+shift
+for ac_tag
+do
+ case $ac_tag in
+ :[FHLC]) ac_mode=$ac_tag; continue;;
+ esac
+ case $ac_mode$ac_tag in
+ :[FHL]*:*);;
+ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;
+ :[FH]-) ac_tag=-:-;;
+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
+ esac
+ ac_save_IFS=$IFS
+ IFS=:
+ set x $ac_tag
+ IFS=$ac_save_IFS
+ shift
+ ac_file=$1
+ shift
- 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`
+ case $ac_mode in
+ :L) ac_source=$1;;
+ :[FH])
+ ac_file_inputs=
+ for ac_f
+ do
+ case $ac_f in
+ -) ac_f="$ac_tmp/stdin";;
+ *) # Look for the file first in the build tree, then in the source tree
+ # (if the path is not absolute). The absolute path cannot be DOS-style,
+ # because $ac_f cannot contain `:'.
+ test -f "$ac_f" ||
+ case $ac_f in
+ [\\/$]*) false;;
+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
+ esac ||
+ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
+ esac
+ case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
+ as_fn_append ac_file_inputs " '$ac_f'"
+ done
+
+ # 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. */
+ configure_input='Generated from '`
+ printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
+ `' by configure.'
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
+printf "%s\n" "$as_me: creating $ac_file" >&6;}
fi
- done
- if test -z "$ac_sed_cmds"; then
- ac_sed_cmds=cat
- fi
-fi # test -n "$CONFIG_FILES"
+ # Neutralize special characters interpreted by sed in replacement strings.
+ case $configure_input in #(
+ *\&* | *\|* | *\\* )
+ ac_sed_conf_input=`printf "%s\n" "$configure_input" |
+ sed 's/[\\\\&|]/\\\\&/g'`;; #(
+ *) ac_sed_conf_input=$configure_input;;
+ esac
-_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 ;;
+ case $ac_tag in
+ *:-:* | *:-) cat >"$ac_tmp/stdin" \
+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;
+ esac
+ ;;
esac
- # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
- ac_dir=`(dirname "$ac_file") 2>/dev/null ||
+ ac_dir=`$as_dirname -- "$ac_file" ||
$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; }; }; }
-
+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
+printf "%s\n" X"$ac_file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)[^/].*/{
+ s//\1/
+ q
+ }
+ /^X\(\/\/\)$/{
+ s//\1/
+ q
+ }
+ /^X\(\/\).*/{
+ s//\1/
+ q
+ }
+ s/.*/./; q'`
+ as_dir="$ac_dir"; as_fn_mkdir_p
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 "$ac_dir" in
+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
+*)
+ ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
+ case $ac_top_builddir_sub in
+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
+ esac ;;
+esac
+ac_abs_top_builddir=$ac_pwd
+ac_abs_builddir=$ac_pwd$ac_dir_suffix
+# for backward compatibility:
+ac_top_builddir=$ac_top_build_prefix
case $srcdir in
- .) # No --srcdir option. We are building in place.
+ .) # 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_top_srcdir=$ac_top_builddir_sub
+ ac_abs_top_srcdir=$ac_pwd ;;
+ [\\/]* | ?:[\\/]* ) # Absolute name.
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 ;;
+ ac_top_srcdir=$srcdir
+ ac_abs_top_srcdir=$srcdir ;;
+ *) # Relative name.
+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_build_prefix$srcdir
+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
-# 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
+ case $ac_mode in
+ :F)
+ #
+ # CONFIG_FILE
+ #
+_ACEOF
- 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; }
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+# If the template does not know about datarootdir, expand it.
+# FIXME: This hack should be removed a few years after 2.60.
+ac_datarootdir_hack=; ac_datarootdir_seen=
+ac_sed_dataroot='
+/datarootdir/ {
+ p
+ q
+}
+/@datadir@/p
+/@docdir@/p
+/@infodir@/p
+/@localedir@/p
+/@mandir@/p'
+case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in
+*datarootdir*) ac_datarootdir_seen=yes;;
+*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ ac_datarootdir_hack='
+ s&@datadir@&$datadir&g
+ s&@docdir@&$docdir&g
+ s&@infodir@&$infodir&g
+ s&@localedir@&$localedir&g
+ s&@mandir@&$mandir&g
+ s&\\\${datarootdir}&$datarootdir&g' ;;
+esac
_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
- sed "$ac_vpsub
+
+# Neutralize VPATH when `$srcdir' = `.'.
+# Shell code in configure.ac might set extrasub.
+# FIXME: do we really want to maintain this feature?
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_sed_extra="$ac_vpsub
$extrasub
_ACEOF
-cat >>$CONFIG_STATUS <<\_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
: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
+s|@configure_input@|$ac_sed_conf_input|;t t
+s&@top_builddir@&$ac_top_builddir_sub&;t t
+s&@top_build_prefix@&$ac_top_build_prefix&;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&@abs_top_builddir@&$ac_abs_top_builddir&;t t
+$ac_datarootdir_hack
+"
+eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
+ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
+
+test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
+ { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
+ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
+ "$ac_tmp/out"`; test -z "$ac_out"; } &&
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined" >&5
+printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
+which seems to be undefined. Please make sure it is defined" >&2;}
+
+ rm -f "$ac_tmp/stdin"
+ case $ac_file in
+ -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;
+ *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;
+ esac \
+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5
+ ;;
-done
-_ACEOF
-cat >>$CONFIG_STATUS <<\_ACEOF
-{ (exit 0); exit 0; }
+ esac
+
+done # for ac_tag
+
+
+as_fn_exit 0
_ACEOF
-chmod +x $CONFIG_STATUS
ac_clean_files=$ac_clean_files_save
+test $ac_write_fail = 0 ||
+ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5
+
# configure is writing to config.log, and then calls config.status.
# config.status does its own redirection, appending to config.log.
@@ -6410,7 +7130,12 @@ if test "$no_create" != yes; then
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; }
+ $ac_cs_success || as_fn_exit 1
+fi
+if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
+ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
+printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
+
diff --git a/win/configure.in b/win/configure.ac
index 2538a92..01f70b4 100644
--- a/win/configure.in
+++ b/win/configure.ac
@@ -3,19 +3,19 @@
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
-AC_INIT([tcl],[8.6])
+AC_INIT([tcl],[8.7])
AC_CONFIG_SRCDIR([../generic/tcl.h])
-AC_PREREQ([2.59])
+AC_PREREQ([2.69])
# The following define is needed when building with Cygwin since newer
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh
-TCL_VERSION=8.6
+TCL_VERSION=8.7
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL=".13"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a6"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.4
@@ -60,7 +60,6 @@ fi
AC_PROG_CC
AC_C_INLINE
-AC_HEADER_STDC
AC_CHECK_TOOL(AR, ar)
AC_CHECK_TOOL(RANLIB, ranlib)
@@ -79,12 +78,6 @@ AC_PROG_MAKE_SET
AC_OBJEXT
AC_EXEEXT
-#--------------------------------------------------------------------
-# Check whether --enable-threads or --disable-threads was given.
-#--------------------------------------------------------------------
-
-SC_ENABLE_THREADS
-
#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
@@ -131,8 +124,9 @@ case ${host_alias} in
esac
#------------------------------------------------------------------------
-# Add stuff for zlib; note that this is mostly done in the makefile now
-# as we just assume that the platform hasn't got a usable z.lib
+# Add stuff for zlib/libtommath; note that this is mostly done in the
+# makefile now as we just assume that the platform hasn't got usable
+# z.lib/tommath.lib
#------------------------------------------------------------------------
AS_IF([test "${enable_shared+set}" = "set"], [
@@ -143,59 +137,84 @@ AS_IF([test "${enable_shared+set}" = "set"], [
])
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
+ AC_SUBST(TOMMATH_DLL_FILE,[\${TOMMATH_DLL_FILE}])
+ AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
AS_IF([test "$do64bit" != "no"], [
+ AC_DEFINE(MP_64BIT, 1, [Using libtommath.dll in 64-bit mode])
AS_IF([test "$do64bit" = "arm64"], [
AS_IF([test "$GCC" == "yes"],[
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a])
+ AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib])
+ AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib])
])
], [
AS_IF([test "$GCC" == "yes"],[
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a])
+ AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib])
+ AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib])
])
])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib])
+ AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win32/tommath.lib])
])
], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
+ AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
-AC_CHECK_TYPE([intptr_t], [
- AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
- AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
- for tcl_cv_intptr_t in "int" "long" "long long" none; do
- if test "$tcl_cv_intptr_t" != none; then
- AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
- [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])],
- [tcl_ok=yes], [tcl_ok=no])
- test "$tcl_ok" = yes && break; fi
- done])
- if test "$tcl_cv_intptr_t" != none; then
- AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer
- type wide enough to hold a pointer.])
- fi
-])
-AC_CHECK_TYPE([uintptr_t], [
- AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [
- AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [
- for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \
- none; do
- if test "$tcl_cv_uintptr_t" != none; then
- AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
- [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])],
- [tcl_ok=yes], [tcl_ok=no])
- test "$tcl_ok" = yes && break; fi
- done])
- if test "$tcl_cv_uintptr_t" != none; then
- AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer
- type wide enough to hold a pointer.])
+AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
+#include <stdint.h>
+]])
+
+#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+AC_ARG_ENABLE(zipfs,
+ AS_HELP_STRING([--enable-zipfs],
+ [build with Zipfs support (default: on)]),
+ [tcl_ok=$enableval], [tcl_ok=yes])
+if test "$tcl_ok" = "yes" ; then
+ #
+ # Find a native compiler
+ #
+ AX_CC_FOR_BUILD
+ #
+ # Find a native zip implementation
+ #
+ SC_PROG_TCLSH
+ SC_ZIPFS_SUPPORT
+ ZIPFS_BUILD=1
+ TCL_ZIP_FILE=libtcl${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}${TCL_PATCH_LEVEL}.zip
+else
+ ZIPFS_BUILD=0
+ TCL_ZIP_FILE=
+fi
+# Do checking message here to not mess up interleaved configure output
+AC_MSG_CHECKING([for building with zipfs])
+if test "${ZIPFS_BUILD}" = 1; then
+ if test "${SHARED_BUILD}" = 0; then
+ ZIPFS_BUILD=2;
+ AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?])
+ else
+ AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\
fi
-])
+ AC_MSG_RESULT([yes])
+else
+AC_MSG_RESULT([no])
+INSTALL_LIBRARIES=install-libraries
+INSTALL_MSGS=install-msgs
+fi
+AC_SUBST(ZIPFS_BUILD)
+AC_SUBST(TCL_ZIP_FILE)
+AC_SUBST(INSTALL_LIBRARIES)
+AC_SUBST(INSTALL_MSGS)
+
#--------------------------------------------------------------------
# Perform additinal compiler tests.
@@ -288,8 +307,6 @@ fi
SC_ENABLE_SYMBOLS
-TCL_DBGX=${DBGX}
-
#--------------------------------------------------------------------
# Embed the manifest if we can determine how
#--------------------------------------------------------------------
@@ -328,11 +345,6 @@ eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
-eval "DLLSUFFIX=${DLLSUFFIX}"
-eval "LIBPREFIX=${LIBPREFIX}"
-eval "LIBSUFFIX=${LIBSUFFIX}"
-eval "EXESUFFIX=${EXESUFFIX}"
-
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
@@ -347,17 +359,9 @@ CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
#--------------------------------------------------------------------
if test ${SHARED_BUILD} = 0 ; then
- if test "${DBGX}" = "g"; then
- RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG"
- else
- RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
- fi
+ RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
else
- if test "${DBGX}" = "g"; then
- RC_DEFINES="${RC_DEFINE} DEBUG"
- else
- RC_DEFINES=""
- fi
+ RC_DEFINES=""
fi
#--------------------------------------------------------------------
@@ -412,7 +416,6 @@ AC_SUBST(TCL_DLL_FILE)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_BIN_DIR)
-AC_SUBST(TCL_DBGX)
AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)
@@ -481,7 +484,7 @@ AC_SUBST(RC_DEFINE)
AC_SUBST(RC_DEFINES)
AC_SUBST(RES)
-AC_CONFIG_FILES(Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest)
+AC_CONFIG_FILES([Makefile tclConfig.sh tclsh.exe.manifest])
AC_OUTPUT
dnl Local Variables:
diff --git a/win/makefile.vc b/win/makefile.vc
index f8facb1..d1f4ef3 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -52,24 +52,27 @@
# turn on the 64-bit compiler, if your SDK has it.
#
# Basic macros and options usable on the commandline (see rules.vc for more info):
-# OPTS=msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,time64bit,unchecked,utf16,none
+# OPTS=msvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,time64bit,unchecked,utf16,none
# Sets special options for the core. The default is for none.
# Any combination of the above may be used (comma separated).
# 'none' will over-ride everything to nothing.
#
-# msvcrt = Affects the static option only to switch it from
-# using libcmt(d) as the C runtime [by default] to
-# msvcrt(d). This is useful for static embedding
+# noembed = Without this option, the Tcl core library scripts
+# are embedded into the executable if "static" is
+# specified in OPTS, or into the DLL otherwise. If
+# "noembed" is specified, the scripts are not embedded
+# but copied to the installation target (as in 8.6).
+# nomsvcrt = Affects the static option only to switch it from
+# using msvcrt(d) as the C runtime [by default] to
+# libcmt(d). This is useful for static embedding
# support.
# none = Overrides all other options to nothing.
# nothreads = Turns off full multithreading support (default on).
# pdbs = Produce separate debug symbol files.
# profile = Adds profiling hooks. Map file is assumed.
# static = Builds a static library of the core instead of a
-# dll. The shell will be static (and large), as well.
-# staticpkg = Affects the static option only to switch
-# tclshXX.exe to have the dde and reg extension linked
-# inside it.
+# dll. The shell will be static (and large), and
+# have the dde and registry extensions linked inside.
# symbols = Adds symbols for step debugging.
# thrdalloc = Use the thread allocator (shared global free pool).
# time64bit = Forces a build using 64-bit time_t for 32-bit build
@@ -145,6 +148,27 @@ RCFILE = tcl.rc
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
+# The staticpkg option is not longer supported in Tcl 8.7
+# though extensions may still be using it. If specified together
+# with "static", ignore it as that is now the default for
+# static build. For non-static builds, no longer supported
+# now (was permitted in 8.6)
+!if $(TCL_USE_STATIC_PACKAGES)
+!if $(STATIC_BUILD)
+!message *** NOTE: The "staticpkg" option redundant in 8.7.
+!else
+!message *** NOTE: The "staticpkg" option ignored for shared library builds.
+!endif
+!endif
+
+!if [nmakehlp -f $(OPTS) "noembed"]
+!message *** Option noembed specified. Tcl script library will not be appended to the binary.
+TCL_EMBED_SCRIPTS = 0
+!else
+!message *** Tcl script library will be appended to the binary.
+TCL_EMBED_SCRIPTS = 1
+!endif
+
# We need versions of various core packages to generate appropriate
# file names during installation.
!if [echo REM = This file is generated from makefile.vc > versions.vc]
@@ -155,6 +179,9 @@ VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
!if [echo PKG_OPT_VER = \>> versions.vc] \
&& [nmakehlp -V ..\library\opt\pkgIndex.tcl opt >> versions.vc]
!endif
+!if [echo PKG_COOKIEJAR_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\cookiejar\pkgIndex.tcl cookiejar >> versions.vc]
+!endif
!if [echo PKG_TCLTEST_VER = \>> versions.vc] \
&& [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc]
!endif
@@ -171,7 +198,7 @@ VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
&& [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc]
!endif
!if [echo PKG_REG_VER =\>> versions.vc] \
- && [nmakehlp -V ..\library\reg\pkgIndex.tcl "registry " >> versions.vc]
+ && [nmakehlp -V ..\library\registry\pkgIndex.tcl "registry " >> versions.vc]
!endif
!include versions.vc
@@ -182,23 +209,16 @@ DDEVERSION = $(DDEDOTVERSION:.=)
REGDOTVERSION = 1.3
REGVERSION = $(REGDOTVERSION:.=)
-TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT)
+TCLREGLIBNAME = $(PROJECT)registry$(REGVERSION)$(SUFX:t=).$(EXT)
TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME)
TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT)
TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME)
TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe
-CAT32 = $(OUT_DIR)\cat32.exe
TCLSHOBJS = \
$(TMP_DIR)\tclAppInit.obj \
-!if !$(STATIC_BUILD)
-!if $(TCL_USE_STATIC_PACKAGES)
- $(TMP_DIR)\tclWinReg.obj \
- $(TMP_DIR)\tclWinDde.obj \
-!endif
-!endif
$(TMP_DIR)\tclsh.res
TCLTESTOBJS = \
@@ -208,10 +228,7 @@ TCLTESTOBJS = \
$(TMP_DIR)\tclThreadTest.obj \
$(TMP_DIR)\tclWinTest.obj \
!if !$(STATIC_BUILD)
-!if $(TCL_USE_STATIC_PACKAGES)
- $(TMP_DIR)\tclWinReg.obj \
- $(TMP_DIR)\tclWinDde.obj \
-!endif
+ $(OUT_DIR)\tommath.lib \
!endif
$(TMP_DIR)\testMain.obj
@@ -221,6 +238,7 @@ COREOBJS = \
$(TMP_DIR)\regexec.obj \
$(TMP_DIR)\regfree.obj \
$(TMP_DIR)\tclAlloc.obj \
+ $(TMP_DIR)\tclArithSeries.obj \
$(TMP_DIR)\tclAssembly.obj \
$(TMP_DIR)\tclAsync.obj \
$(TMP_DIR)\tclBasic.obj \
@@ -284,6 +302,7 @@ COREOBJS = \
$(TMP_DIR)\tclPosixStr.obj \
$(TMP_DIR)\tclPreserve.obj \
$(TMP_DIR)\tclProc.obj \
+ $(TMP_DIR)\tclProcess.obj \
$(TMP_DIR)\tclRegexp.obj \
$(TMP_DIR)\tclResolve.obj \
$(TMP_DIR)\tclResult.obj \
@@ -301,6 +320,7 @@ COREOBJS = \
$(TMP_DIR)\tclUtf.obj \
$(TMP_DIR)\tclUtil.obj \
$(TMP_DIR)\tclVar.obj \
+ $(TMP_DIR)\tclZipfs.obj \
$(TMP_DIR)\tclZlib.obj
!if $(STATIC_BUILD)
@@ -320,6 +340,7 @@ ZLIBOBJS = \
ZLIBOBJS = $(OUT_DIR)\zdll.lib
!endif
+!if $(STATIC_BUILD)
TOMMATHOBJS = \
$(TMP_DIR)\bn_mp_add.obj \
$(TMP_DIR)\bn_mp_add_d.obj \
@@ -340,12 +361,15 @@ TOMMATHOBJS = \
$(TMP_DIR)\bn_mp_div_3.obj \
$(TMP_DIR)\bn_mp_exch.obj \
$(TMP_DIR)\bn_mp_expt_u32.obj \
+ $(TMP_DIR)\bn_mp_get_mag_u64.obj \
$(TMP_DIR)\bn_mp_grow.obj \
$(TMP_DIR)\bn_mp_init.obj \
$(TMP_DIR)\bn_mp_init_copy.obj \
+ $(TMP_DIR)\bn_mp_init_i64.obj \
$(TMP_DIR)\bn_mp_init_multi.obj \
$(TMP_DIR)\bn_mp_init_set.obj \
$(TMP_DIR)\bn_mp_init_size.obj \
+ $(TMP_DIR)\bn_mp_init_u64.obj \
$(TMP_DIR)\bn_mp_lshd.obj \
$(TMP_DIR)\bn_mp_mod.obj \
$(TMP_DIR)\bn_mp_mod_2d.obj \
@@ -361,7 +385,8 @@ TOMMATHOBJS = \
$(TMP_DIR)\bn_mp_radix_smap.obj \
$(TMP_DIR)\bn_mp_read_radix.obj \
$(TMP_DIR)\bn_mp_rshd.obj \
- $(TMP_DIR)\bn_mp_set.obj \
+ $(TMP_DIR)\bn_mp_set_i64.obj \
+ $(TMP_DIR)\bn_mp_set_u64.obj \
$(TMP_DIR)\bn_mp_shrink.obj \
$(TMP_DIR)\bn_mp_sqr.obj \
$(TMP_DIR)\bn_mp_sqrt.obj \
@@ -386,6 +411,9 @@ TOMMATHOBJS = \
$(TMP_DIR)\bn_s_mp_sub.obj \
$(TMP_DIR)\bn_s_mp_toom_sqr.obj \
$(TMP_DIR)\bn_s_mp_toom_mul.obj
+!else
+TOMMATHOBJS = $(OUT_DIR)\tommath.lib
+!endif
PLATFORMOBJS = \
$(TMP_DIR)\tclWin32Dll.obj \
@@ -403,6 +431,7 @@ PLATFORMOBJS = \
$(TMP_DIR)\tclWinThrd.obj \
$(TMP_DIR)\tclWinTime.obj \
!if $(STATIC_BUILD)
+ $(TMP_DIR)\tclWinPanic.obj \
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!else
@@ -414,13 +443,16 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS)
TCLSTUBOBJS = \
$(TMP_DIR)\tclStubLib.obj \
$(TMP_DIR)\tclTomMathStubLib.obj \
- $(TMP_DIR)\tclOOStubLib.obj
+ $(TMP_DIR)\tclOOStubLib.obj \
+ $(TMP_DIR)\tclWinPanic.obj
### The following paths CANNOT have spaces in them as they appear on
### the left side of implicit rules.
TOMMATHDIR = $(ROOT)\libtommath
PKGSDIR = $(ROOT)\pkgs
+LIBTCLVFS = $(OUT_DIR)\libtcl.vfs
+
# Additional include and C macro definitions for the implicit rules
# defined in rules.vc
PRJ_INCLUDES = -I"$(TOMMATHDIR)"
@@ -442,12 +474,22 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT)
# Project specific targets
#---------------------------------------------------------------------
-release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
+release: setup $(TCLSH) $(TCLSTUBLIB) dlls libtclzip embed pkgs
core: setup $(TCLLIB) $(TCLSTUBLIB)
shell: setup $(TCLSH)
-dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll
-all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs
-tcltest: setup $(TCLTEST) dlls $(CAT32)
+dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll
+libtclzip: core dlls $(TCLSCRIPTZIP)
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls libtclzip embed pkgs
+embed: setup $(TCLSH) $(TCLSTUBLIB) libtclzip
+!if $(TCL_EMBED_SCRIPTS)
+!if $(STATIC_BUILD)
+ @copy /y /b "$(TCLSH)"+"$(TCLSCRIPTZIP)" "$(TCLSH)"
+!else
+ @copy /y /b "$(TCLLIB)"+"$(TCLSCRIPTZIP)" "$(TCLLIB)"
+!endif
+!endif
+
+tcltest: setup $(TCLTEST) dlls
install: install-binaries install-libraries install-docs install-pkgs
!if $(SYMBOLS)
install: install-pdbs
@@ -455,14 +497,14 @@ install: install-pdbs
setup: default-setup
test: test-core test-pkgs
-test-core: setup $(TCLTEST) dlls $(CAT32)
+test-core: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.4.4 [list load "$(TCLDDELIB:\=/)" Dde]
- package ifneeded registry 1.3.5 [list load "$(TCLREGLIB:\=/)" Registry]
+ package ifneeded dde 1.4.5 [list load "$(TCLDDELIB:\=/)"]
+ package ifneeded registry 1.3.7 [list load "$(TCLREGLIB:\=/)"]
<<
-runtest: setup $(TCLTEST) dlls $(CAT32)
+runtest: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) $(SCRIPT)
@@ -523,18 +565,51 @@ $(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win64-arm\zlib1.dll
$(COPY) $(COMPATDIR)\zlib\win64-arm\zlib1.dll $(OUT_DIR)\zlib1.dll
$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win64-arm\zdll.lib
$(COPY) $(COMPATDIR)\zlib\win64-arm\zdll.lib $(OUT_DIR)\zdll.lib
+$(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win64-arm\libtommath.dll
+ $(COPY) $(TOMMATHDIR)\win64-arm\libtommath.dll $(OUT_DIR)\libtommath.dll
+$(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64-arm\tommath.lib
+ $(COPY) $(TOMMATHDIR)\win64-arm\tommath.lib $(OUT_DIR)\tommath.lib
!elseif "$(MACHINE)" == "IX86"
$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win32\zlib1.dll
$(COPY) $(COMPATDIR)\zlib\win32\zlib1.dll $(OUT_DIR)\zlib1.dll
$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win32\zdll.lib
$(COPY) $(COMPATDIR)\zlib\win32\zdll.lib $(OUT_DIR)\zdll.lib
+$(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win32\libtommath.dll
+ $(COPY) $(TOMMATHDIR)\win32\libtommath.dll $(OUT_DIR)\libtommath.dll
+$(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win32\tommath.lib
+ $(COPY) $(TOMMATHDIR)\win32\tommath.lib $(OUT_DIR)\tommath.lib
!else
$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win64\zlib1.dll
$(COPY) $(COMPATDIR)\zlib\win64\zlib1.dll $(OUT_DIR)\zlib1.dll
$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win64\zdll.lib
$(COPY) $(COMPATDIR)\zlib\win64\zdll.lib $(OUT_DIR)\zdll.lib
+$(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win64\libtommath.dll
+ $(COPY) $(TOMMATHDIR)\win64\libtommath.dll $(OUT_DIR)\libtommath.dll
+$(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib
+ $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib
!endif
+$(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB)
+ @echo Building Tcl library zip file
+ @if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)"
+ @$(MKDIR) "$(LIBTCLVFS)"
+ @$(CPYDIR) $(LIBDIR) "$(LIBTCLVFS)\tcl_library"
+ @move /y "$(LIBTCLVFS)\tcl_library\manifest.txt" "$(LIBTCLVFS)\tcl_library\pkgIndex.tcl" > NUL
+!if $(STATIC_BUILD)
+# Remove the registry and dde directories as the DLLS are still external
+ @del "$(LIBTCLVFS)\tcl_library\registry\pkgIndex.tcl"
+ @rmdir "$(LIBTCLVFS)\tcl_library\registry"
+ @del "$(LIBTCLVFS)\tcl_library\dde\pkgIndex.tcl"
+ @rmdir "$(LIBTCLVFS)\tcl_library\dde"
+!else
+ @$(COPY) $(TCLDDELIB) "$(LIBTCLVFS)\tcl_library\dde
+ @$(COPY) $(TCLREGLIB) "$(LIBTCLVFS)\tcl_library\registry
+!endif
+ @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl"
+ @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl"
+ @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl
+
+
pkgs:
@for /d %d in ($(PKGSDIR)\*) do \
@if exist "%~fd\win\makefile.vc" ( \
@@ -567,12 +642,6 @@ clean-pkgs:
popd \
)
-$(CAT32): $(WIN_DIR)\cat.c
- $(cc32) $(cflags) $(crt) /D_CRT_NONSTDC_NO_DEPRECATE /DCONSOLE \
- /DUNICODE /D_UNICODE -Fo$(TMP_DIR)\ $?
- $(CONEXECMD) -stack:16384 $(TMP_DIR)\cat.obj
- $(_VC_MANIFEST_EMBED_EXE)
-
#---------------------------------------------------------------------
# Regenerate the stubs files. [Development use only]
#---------------------------------------------------------------------
@@ -588,22 +657,6 @@ genstubs:
$(GENERICDIR:\=/)/tclOO.decls
!endif
-
-#----------------------------------------------------------------------
-# The following target generates the file generic/tclTomMath.h.
-# It needs to be run (and the results checked) after updating
-# to a new release of libtommath.
-#----------------------------------------------------------------------
-
-gentommath_h:
-!if !exist($(TCLSH))
- @echo Build tclsh first!
-!else
- $(TCLSH) "$(TOOLSDIR:\=/)/fix_tommath_h.tcl" \
- "$(TOMMATHDIR:\=/)/tommath.h" \
- > "$(GENERICDIR)\tclTomMath.h"
-!endif
-
#---------------------------------------------------------------------
# Build the Windows HTML help file.
#---------------------------------------------------------------------
@@ -666,7 +719,6 @@ $(OUT_DIR)\tcl.nmake:
@type << >$@
CORE_MACHINE = $(MACHINE)
CORE_DEBUG = $(DEBUG)
-CORE_TCL_THREADS = $(TCL_THREADS)
CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC)
<<
@@ -691,7 +743,6 @@ $(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in
@CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD
@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv
@LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3
-@TCL_DBGX@ $(SUFX)
@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib
@TCL_NEEDS_EXP_FILE@
@LIBS@ $(baselibs) $(PRJ_LIBS)
@@ -721,7 +772,6 @@ $(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in
@TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME)
@TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME)
@TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME)
-@TCL_THREADS@ $(TCL_THREADS)
@TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME)
@TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB)
@TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME)
@@ -755,7 +805,6 @@ gendate:
$(TMP_DIR)\testMain.obj: $(WIN_DIR)\tclAppInit.c
$(cc32) $(appcflags) /DTCL_TEST /DUNICODE /D_UNICODE \
- /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
-Fo$@ $?
$(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c
@@ -773,8 +822,9 @@ $(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h
$(cc32) $(pkgcflags) -I$(TMP_DIR) \
-Fo$@ $(GENERICDIR)\tclEvent.c
-$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
- $(cc32) $(appcflags) -Fo$@ $?
+$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h
+ $(cc32) $(appcflags) -I$(TMP_DIR) \
+ -Fo$@ $(GENERICDIR)\tclTest.c
$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(cc32) $(appcflags) -Fo$@ $?
@@ -782,9 +832,27 @@ $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c
$(CCAPPCMD) $?
+$(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c
+ $(cc32) $(pkgcflags) \
+ -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip \
+ -Fo$@ $?
+
$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c
$(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $?
+# Following the lead of the autoconf based make, we define the
+# CFG_RUNTIME_*DIR flags specifically for tclPkgConfig
+# and not as part of the global defines. These are all defined
+# as empty strings because they are intended to represent paths
+# at *runtime*, not build time. This may make sense on Unix systems
+# where end-user does configure and make on the target system. It
+# makes no sense on Windows where binary distributions may be installed
+# anywhere. Storing build time paths as runtime paths is misleading
+# at best and inefficient at worst as the code goes looking for
+# files and directories that do not exist.
+# Note: the same is true for the other CFG_RUNTIME* and CFG_INSTALL*
+# settings as well but they are historical and I do not want to change
+# them.
$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
$(cc32) $(pkgcflags) \
/DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
@@ -797,15 +865,14 @@ $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
/DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \
/DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \
/DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \
+ /DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \
-Fo$@ $?
$(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c
$(cc32) $(appcflags) /DUNICODE /D_UNICODE \
- /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
-Fo$@ $?
### The following objects should be built using the stub interfaces
-### *ALL* extensions need to built with /DTCL_THREADS=1
$(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c
$(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $?
@@ -828,6 +895,9 @@ $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c
$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c
$(cc32) $(stubscflags) -Fo$@ $?
+$(TMP_DIR)\tclWinPanic.obj: $(WIN_DIR)\tclWinPanic.c
+ $(cc32) $(stubscflags) -Fo$@ $?
+
$(TMP_DIR)\tclsh.exe.manifest: $(WIN_DIR)\tclsh.exe.manifest.in
@nmakehlp -s << $** >$@
@MACHINE@ $(MACHINE:IX86=X86)
@@ -900,6 +970,7 @@ install-binaries:
!endif
@$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\zlib1.dll" "$(BIN_INSTALL_DIR)\"
+ @$(CPY) "$(OUT_DIR)\libtommath.dll" "$(BIN_INSTALL_DIR)\"
!if exist($(TCLSH))
@echo Installing $(TCLSHNAME)
@$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\"
@@ -908,20 +979,6 @@ install-binaries:
@$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\"
install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
- @if not exist "$(SCRIPT_INSTALL_DIR)" \
- $(MKDIR) "$(SCRIPT_INSTALL_DIR)"
- @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \
- $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
- @if not exist "$(MODULE_INSTALL_DIR)" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)"
- @if not exist "$(MODULE_INSTALL_DIR)\8.4" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4"
- @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform"
- @if not exist "$(MODULE_INSTALL_DIR)\8.5" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
- @if not exist "$(MODULE_INSTALL_DIR)\8.6" \
- $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
@if not exist "$(LIB_INSTALL_DIR)\nmake" \
$(MKDIR) "$(LIB_INSTALL_DIR)\nmake"
@echo Installing header files
@@ -932,7 +989,11 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
@$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(TOMMATHDIR)\tommath.h" "$(INCLUDE_INSTALL_DIR)\"
+!if !$(TCL_EMBED_SCRIPTS)
@echo Installing library files to $(SCRIPT_INSTALL_DIR)
+ @if not exist "$(SCRIPT_INSTALL_DIR)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)"
@$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\"
@@ -943,70 +1004,90 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
@$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\"
+!endif
@$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(WIN_DIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\"
+ @$(CPY) "$(TCLSCRIPTZIP)" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(WIN_DIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WIN_DIR)\x86_64-w64-mingw32-nmakehlp.exe" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\"
- @echo Installing package http 1.0 (obsolete)
- @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \
- "$(SCRIPT_INSTALL_DIR)\http1.0\"
+!if !$(TCL_EMBED_SCRIPTS)
+ @echo Installing package cookiejar $(PKG_COOKIEJAR_VER)
+ @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2"
+ @$(CPY) "$(ROOT)\library\cookiejar\*.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\cookiejar0.2\"
+ @$(CPY) "$(ROOT)\library\cookiejar\*.gz" \
+ "$(SCRIPT_INSTALL_DIR)\cookiejar0.2\"
@echo Installing package opt $(PKG_OPT_VER)
+ @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
@$(CPY) "$(ROOT)\library\opt\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\opt0.4\"
+ @if not exist "$(MODULE_INSTALL_DIR)" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)"
@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.6" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
@$(COPY) "$(ROOT)\library\http\http.tcl" \
"$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.7" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.7"
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
- "$(MODULE_INSTALL_DIR)\8.5\msgcat-$(PKG_MSGCAT_VER).tm"
+ "$(MODULE_INSTALL_DIR)\8.7\msgcat-$(PKG_MSGCAT_VER).tm"
@echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.5" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
"$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
@echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module
+ @if not exist "$(MODULE_INSTALL_DIR)\8.4" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4"
+ @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform"
@$(COPY) "$(ROOT)\library\platform\platform.tcl" \
"$(MODULE_INSTALL_DIR)\8.4\platform-$(PKG_PLATFORM_VER).tm"
@echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\platform\shell.tcl" \
"$(MODULE_INSTALL_DIR)\8.4\platform\shell-$(PKG_SHELL_VER).tm"
- @echo Installing $(TCLDDELIBNAME)
-!if $(STATIC_BUILD)
-!if !$(TCL_USE_STATIC_PACKAGES)
- @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\"
!endif
-!else
+ @echo Installing $(TCLDDELIBNAME)
+!if !$(STATIC_BUILD)
@$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
@$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \
"$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
!endif
@echo Installing $(TCLREGLIBNAME)
-!if $(STATIC_BUILD)
-!if !$(TCL_USE_STATIC_PACKAGES)
- @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\"
-!endif
-!else
- @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\"
- @$(CPY) "$(ROOT)\library\reg\pkgIndex.tcl" \
- "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\"
+!if !$(STATIC_BUILD)
+ @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\registry$(REGDOTVERSION)\"
+ @$(CPY) "$(ROOT)\library\registry\pkgIndex.tcl" \
+ "$(LIB_INSTALL_DIR)\registry$(REGDOTVERSION)\"
!endif
+!if !$(TCL_EMBED_SCRIPTS)
@echo Installing encodings
@$(CPY) "$(ROOT)\library\encoding\*.enc" \
"$(SCRIPT_INSTALL_DIR)\encoding\"
+!endif
# "emacs font-lock highlighting fix
install-tzdata:
+!if !$(TCL_EMBED_SCRIPTS)
@echo Installing time zone data
@set TCL_LIBRARY=$(ROOT:\=/)/library
@$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
"$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata"
+!endif
install-msgs:
+!if !$(TCL_EMBED_SCRIPTS)
@echo Installing message catalogs
@set TCL_LIBRARY=$(ROOT:\=/)/library
@$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
"$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs"
+!endif
install-pdbs:
@echo Installing debug symbols
diff --git a/win/nmakehlp.c b/win/nmakehlp.c
index 0ebaf63..e0941e3 100644
--- a/win/nmakehlp.c
+++ b/win/nmakehlp.c
@@ -21,15 +21,6 @@
#include <stdio.h>
#include <math.h>
-/*
- * This library is required for x64 builds with _some_ versions of MSVC
- */
-#if defined(_M_IA64) || defined(_M_AMD64)
-#if _MSC_VER >= 1400 && _MSC_VER < 1500
-#pragma comment(lib, "bufferoverflowU")
-#endif
-#endif
-
/* ISO hack for dumb VC++ */
#ifdef _MSC_VER
#define snprintf _snprintf
@@ -727,11 +718,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath)
int keylen, ret;
WIN32_FIND_DATA finfo;
- if (dir == NULL || keypath == NULL)
+ if (dir == NULL || keypath == NULL) {
return 2; /* Have no real error reporting mechanism into nmake */
+ }
dirlen = strlen(dir);
- if ((dirlen + 3) > sizeof(path))
+ if ((dirlen + 3) > sizeof(path)) {
return 2;
+ }
strncpy(path, dir, dirlen);
strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
keylen = strlen(keypath);
@@ -797,8 +790,9 @@ static int LocateDependency(const char *keypath)
for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
ret = LocateDependencyHelper(paths[i], keypath);
- if (ret == 0)
+ if (ret == 0) {
return ret;
+ }
}
return ret;
}
diff --git a/win/rules.vc b/win/rules.vc
index 0dfe609..d8b3b12 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -24,7 +24,7 @@ _RULES_VC = 1
# For modifications that are not backward-compatible, you *must* change
# the major version.
RULES_VERSION_MAJOR = 1
-RULES_VERSION_MINOR = 10
+RULES_VERSION_MINOR = 11
# The PROJECT macro must be defined by parent makefile.
!if "$(PROJECT)" == ""
@@ -877,6 +877,11 @@ TCL_THREADS = 0
USE_THREAD_ALLOC= 0
!endif
+!if [nmakehlp -f $(OPTS) "tcl8"]
+!message *** Build for Tcl8
+TCL_BUILD_FOR = 8
+!endif
+
!if $(TCL_MAJOR_VERSION) == 8
!if [nmakehlp -f $(OPTS) "time64bit"]
!message *** Force 64-bit time_t
@@ -1146,7 +1151,11 @@ TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
TCLLIB = $(OUT_DIR)\$(TCLLIBNAME)
TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME)
+!if $(TCL_MAJOR_VERSION) == 8
TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
+!else
+TCLSTUBLIBNAME = $(STUBPREFIX).lib
+!endif
TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)
TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
@@ -1162,7 +1171,11 @@ TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe
TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
+!if $(TCL_MAJOR_VERSION) == 8
TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib
+!else
+TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib
+!endif
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
@@ -1182,7 +1195,11 @@ TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!if !exist($(TCLSH))
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
+!if $(TCL_MAJOR_VERSION) == 8
TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib
+!else
+TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib
+!endif
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
@@ -1198,7 +1215,11 @@ TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif # TCLINSTALL
+!if !$(STATIC_BUILD) && "$(TCL_BUILD_FOR)" == "8"
+tcllibs = "$(TCLSTUBLIB)"
+!else
tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)"
+!endif
!endif # $(DOING_TCL)
@@ -1218,7 +1239,7 @@ WISHNAMEPREFIX = wish
WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe
TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT)
TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT)
-!if $(TCL_MAJOR_VERSION) == 8
+!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8"
TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT)
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib
!else
@@ -1275,14 +1296,18 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)"
PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT)
-!if $(TCL_MAJOR_VERSION) == 8
+!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8"
PRJLIBNAME = $(PRJLIBNAME8)
!else
PRJLIBNAME = $(PRJLIBNAME9)
!endif
PRJLIB = $(OUT_DIR)\$(PRJLIBNAME)
+!if $(TCL_MAJOR_VERSION) == 8
PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
+!else
+PRJSTUBLIBNAME = $(STUBPREFIX).lib
+!endif
PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME)
# If extension parent makefile has not defined a resource definition file,
@@ -1429,6 +1454,9 @@ COMPILERFLAGS = /D_ATL_XP_TARGETING
!if "$(TCL_UTF_MAX)" == "3"
OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3
!endif
+!if "$(TCL_BUILD_FOR)" == "8"
+OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8
+!endif
# Like the TEA system only set this non empty for non-Tk extensions
# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
diff --git a/win/tcl.dsp b/win/tcl.dsp
index 4f35cb3..aff1000 100644
--- a/win/tcl.dsp
+++ b/win/tcl.dsp
@@ -34,18 +34,18 @@ CFG=tcl - Win32 Debug Static
# PROP BASE Use_Debug_Libraries 0
# PROP BASE Output_Dir "Release"
# PROP BASE Intermediate_Dir "Release\tcl_Dynamic"
-# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=none MSVCDIR=IDE"
+# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Release\tclsh86.exe"
+# PROP BASE Target_File "Release\tclsh87.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 0
# PROP Output_Dir "Release"
# PROP Intermediate_Dir "Release\tcl_Dynamic"
-# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads MSVCDIR=IDE"
+# PROP Cmd_Line "nmake -nologo -f makefile.vc MSVCDIR=IDE"
# PROP Rebuild_Opt "clean release"
-# PROP Target_File "Release\tclsh86t.exe"
+# PROP Target_File "Release\tclsh87t.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -57,7 +57,7 @@ CFG=tcl - Win32 Debug Static
# PROP BASE Intermediate_Dir "Debug\tcl_Dynamic"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Debug\tclsh86g.exe"
+# PROP BASE Target_File "Debug\tclsh87g.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -66,7 +66,7 @@ CFG=tcl - Win32 Debug Static
# PROP Intermediate_Dir "Debug\tcl_Dynamic"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads,symbols MSVCDIR=IDE"
# PROP Rebuild_Opt "clean release"
-# PROP Target_File "Debug\tclsh86tg.exe"
+# PROP Target_File "Debug\tclsh87tg.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -78,7 +78,7 @@ CFG=tcl - Win32 Debug Static
# PROP BASE Intermediate_Dir "Debug\tcl_Static"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Debug\tclsh86sg.exe"
+# PROP BASE Target_File "Debug\tclsh87sg.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -87,7 +87,7 @@ CFG=tcl - Win32 Debug Static
# PROP Intermediate_Dir "Debug\tcl_Static"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
-# PROP Target_File "Debug\tclsh86sg.exe"
+# PROP Target_File "Debug\tclsh87sg.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -99,7 +99,7 @@ CFG=tcl - Win32 Debug Static
# PROP BASE Intermediate_Dir "Release\tcl_Static"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Release\tclsh86s.exe"
+# PROP BASE Target_File "Release\tclsh87s.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -108,7 +108,7 @@ CFG=tcl - Win32 Debug Static
# PROP Intermediate_Dir "Release\tcl_Static"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
-# PROP Target_File "Release\tclsh86s.exe"
+# PROP Target_File "Release\tclsh87s.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -148,14 +148,6 @@ SOURCE=..\compat\dlfcn.h
# End Source File
# Begin Source File
-SOURCE=..\compat\fixstrtod.c
-# End Source File
-# Begin Source File
-
-SOURCE=..\compat\float.h
-# End Source File
-# Begin Source File
-
SOURCE=..\compat\gettod.c
# End Source File
# Begin Source File
@@ -192,10 +184,6 @@ SOURCE=..\compat\strstr.c
# End Source File
# Begin Source File
-SOURCE=..\compat\strtod.c
-# End Source File
-# Begin Source File
-
SOURCE=..\compat\strtol.c
# End Source File
# Begin Source File
@@ -208,10 +196,6 @@ SOURCE=..\compat\tclErrno.h
# End Source File
# Begin Source File
-SOURCE=..\compat\unistd.h
-# End Source File
-# Begin Source File
-
SOURCE=..\compat\waitpid.c
# End Source File
# End Group
@@ -776,7 +760,7 @@ SOURCE=..\doc\safe.n
# End Source File
# Begin Source File
-SOURCE=..\doc\SaveResult.3
+SOURCE=..\doc\SaveInterpState.3
# End Source File
# Begin Source File
@@ -840,7 +824,7 @@ SOURCE=..\doc\SplitPath.3
# End Source File
# Begin Source File
-SOURCE=..\doc\StaticPkg.3
+SOURCE=..\doc\StaticLibrary.3
# End Source File
# Begin Source File
@@ -1268,6 +1252,10 @@ SOURCE=..\generic\tclProc.c
# End Source File
# Begin Source File
+SOURCE=..\generic\tclProcess.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclRegexp.c
# End Source File
# Begin Source File
@@ -1424,7 +1412,7 @@ SOURCE=.\configure
# End Source File
# Begin Source File
-SOURCE=.\configure.in
+SOURCE=.\configure.ac
# End Source File
# Begin Source File
@@ -1456,10 +1444,6 @@ SOURCE=.\rules.vc
# End Source File
# Begin Source File
-SOURCE=.\tcl.hpj.in
-# End Source File
-# Begin Source File
-
SOURCE=.\tcl.m4
# End Source File
# Begin Source File
@@ -1528,6 +1512,10 @@ SOURCE=.\tclWinNotify.c
# End Source File
# Begin Source File
+SOURCE=.\tclWinPanic.c
+# End Source File
+# Begin Source File
+
SOURCE=.\tclWinPipe.c
# End Source File
# Begin Source File
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in
deleted file mode 100644
index a94cea6..0000000
--- a/win/tcl.hpj.in
+++ /dev/null
@@ -1,19 +0,0 @@
-; This file is maintained by HCW. Do not modify this file directly.
-
-[OPTIONS]
-HCW=0
-LCID=0x409 0x0 0x0 ;English (United States)
-REPORT=Yes
-TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
-COPYRIGHT=Copyright 2000 Ajuba Solutions
-HLP=tcl86.hlp
-
-[FILES]
-tcl.rtf
-
-[WINDOWS]
-main="Tcl/Tk Reference Manual",,0
-
-[CONFIG]
-BrowseButtons()
diff --git a/win/tcl.m4 b/win/tcl.m4
index a0797e8..954c3c0 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -279,14 +279,6 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
fi
- #
- # eval is required to do the TCL_DBGX substitution
- #
-
- eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
- eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
- eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
-
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
@@ -372,42 +364,7 @@ AC_DEFUN([SC_ENABLE_SHARED], [
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
fi
-])
-
-#------------------------------------------------------------------------
-# SC_ENABLE_THREADS --
-#
-# Specify if thread support should be enabled
-#
-# Arguments:
-# none
-#
-# Results:
-#
-# Adds the following arguments to configure:
-# --enable-threads=yes|no
-#
-# Defines the following vars:
-# TCL_THREADS
-#------------------------------------------------------------------------
-
-AC_DEFUN([SC_ENABLE_THREADS], [
- AC_MSG_CHECKING(for building with threads)
- AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)],
- [tcl_ok=$enableval], [tcl_ok=yes])
-
- if test "$tcl_ok" = "yes"; then
- AC_MSG_RESULT([yes (default)])
- TCL_THREADS=1
- AC_DEFINE(TCL_THREADS)
- # USE_THREAD_ALLOC tells us to try the special thread-based
- # allocator that significantly reduces lock contention
- AC_DEFINE(USE_THREAD_ALLOC)
- else
- TCL_THREADS=0
- AC_MSG_RESULT(no)
- fi
- AC_SUBST(TCL_THREADS)
+ AC_SUBST(SHARED_BUILD)
])
#------------------------------------------------------------------------
@@ -434,7 +391,6 @@ AC_DEFUN([SC_ENABLE_THREADS], [
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
-# DBGX Debug library extension
#
#------------------------------------------------------------------------
@@ -445,7 +401,6 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
- DBGX=""
AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?])
AC_MSG_RESULT([no])
@@ -453,7 +408,6 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- DBGX=g
if test "$tcl_ok" = "yes"; then
AC_MSG_RESULT([yes (standard debugging)])
fi
@@ -537,22 +491,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=no])
AC_MSG_RESULT($do64bit)
- # Cross-compiling options for Windows/CE builds
-
- AC_MSG_CHECKING([if Windows/CE build is requested])
- AC_ARG_ENABLE(wince,[ --enable-wince enable Win/CE support (where applicable)], [doWince=$enableval], [doWince=no])
- AC_MSG_RESULT($doWince)
-
- AC_MSG_CHECKING([for Windows/CE celib directory])
- AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR],
- CELIB_DIR=$withval, CELIB_DIR=NO_CELIB)
- AC_MSG_RESULT([$CELIB_DIR])
-
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo)
+ AC_CHECK_PROG(WINE, wine, wine,)
SHLIB_SUFFIX=".dll"
@@ -682,6 +626,14 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
else
CFLAGS_NOLTO=""
fi
+ AC_CACHE_CHECK([if the compiler understands -finput-charset],
+ tcl_cv_cc_input_charset, [
+ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8"
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_input_charset=yes],[tcl_cv_cc_input_charset=no])
+ CFLAGS=$hold_cflags])
+ if test $tcl_cv_cc_input_charset = yes; then
+ extra_cflags="$extra_cflags -finput-charset=UTF-8"
+ fi
fi
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--enable-auto-image-base"
@@ -702,7 +654,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
SHLIB_LD_LIBS='${LIBS}'
LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32"
# mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't
- LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32"
+ LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32 -lwinspool"
STLIB_LD='${AR} cr'
RC_OUT=-o
RC_TYPE=
@@ -720,7 +672,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AC_MSG_RESULT([using static flags])
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
- EXESUFFIX="s\${DBGX}.exe"
+ EXESUFFIX="s.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
@@ -734,7 +686,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
runtime=
# Add SHLIB_LD_LIBS to the Make rule, not here.
- EXESUFFIX="\${DBGX}.exe"
+ EXESUFFIX=".exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# Link with gcc since ld does not link to default libs like
@@ -745,16 +697,16 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
-Wl,--out-implib,\$(patsubst %.dll,lib%.dll.a,\[$]@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
- DLLSUFFIX="\${DBGX}.dll"
- LIBSUFFIX="\${DBGX}.a"
- LIBFLAGSUFFIX="\${DBGX}"
+ DLLSUFFIX=".dll"
+ LIBSUFFIX=".a"
+ LIBFLAGSUFFIX=""
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
- CFLAGS_WARNING="-Wall -Wpointer-arith"
+ CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
@@ -763,7 +715,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
*)
- CFLAGS_WARNING="${CFLAGS_WARNING} -Wdeclaration-after-statement"
+ CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers"
;;
esac
@@ -823,14 +775,14 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AC_MSG_RESULT([using static flags])
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
- EXESUFFIX="s\${DBGX}.exe"
+ EXESUFFIX="s.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
- EXESUFFIX="\${DBGX}.exe"
+ EXESUFFIX=".exe"
case "x`echo \${VisualStudioVersion}`" in
x1[[4-9]]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
@@ -842,9 +794,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
- DLLSUFFIX="\${DBGX}.dll"
- LIBSUFFIX="\${DBGX}.lib"
- LIBFLAGSUFFIX="\${DBGX}"
+ DLLSUFFIX=".dll"
+ LIBSUFFIX=".lib"
+ LIBFLAGSUFFIX=""
if test "$do64bit" != "no" ; then
case "$do64bit" in
@@ -891,98 +843,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
LINKBIN="link"
fi
- if test "$doWince" != "no" ; then
- # Set defaults for common evc4/PPC2003 setup
- # Currently Tcl requires 300+, possibly 420+ for sockets
- CEVERSION=420; # could be 211 300 301 400 420 ...
- TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ...
- ARCH=ARM; # could be ARM MIPS X86EM ...
- PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002"
- if test "$doWince" != "yes"; then
- # If !yes then the user specified something
- # Reset ARCH to allow user to skip specifying it
- ARCH=
- eval `echo $doWince | awk -F "," '{ \
- if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \
- if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \
- if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \
- if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \
- if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \
- }'`
- if test "x${ARCH}" = "x" ; then
- ARCH=$TARGETCPU;
- fi
- fi
- OSVERSION=WCE$CEVERSION;
- if test "x${WCEROOT}" = "x" ; then
- WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0"
- if test ! -d "${WCEROOT}" ; then
- WCEROOT="C:/Program Files/Microsoft eMbedded Tools"
- fi
- fi
- if test "x${SDKROOT}" = "x" ; then
- SDKROOT="C:/Program Files/Windows CE Tools"
- if test ! -d "${SDKROOT}" ; then
- SDKROOT="C:/Windows CE Tools"
- fi
- fi
- # The space-based-path will work for the Makefile, but will
- # not work if AC_TRY_COMPILE is called.
- WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'`
- SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'`
- CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'`
- if test ! -d "${CELIB_DIR}/inc"; then
- AC_MSG_ERROR([Invalid celib directory "${CELIB_DIR}"])
- fi
- if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\
- -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then
- AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]])
- else
- CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include"
- if test -d "${CEINCLUDE}/${TARGETCPU}" ; then
- CEINCLUDE="${CEINCLUDE}/${TARGETCPU}"
- fi
- CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"
- fi
- fi
-
- if test "$doWince" != "no" ; then
- CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin"
- if test "${TARGETCPU}" = "X86"; then
- CC="${CEBINROOT}/cl.exe"
- else
- CC="${CEBINROOT}/cl${ARCH}.exe"
- fi
- CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\""
- RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\""
- arch=`echo ${ARCH} | awk '{print tolower([$]0)}'`
- defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS"
- for i in $defs ; do
- AC_DEFINE_UNQUOTED($i)
- done
-# if test "${ARCH}" = "X86EM"; then
-# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION)
-# fi
- AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION)
- AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION)
- CFLAGS_DEBUG="-nologo -Zi -Od"
- CFLAGS_OPTIMIZE="-nologo -O2"
- lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'`
- lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo"
- LINKBIN="\"${CEBINROOT}/link.exe\""
- AC_SUBST(CELIB_DIR)
- if test "${CEVERSION}" -lt 400 ; then
- LIBS="coredll.lib corelibc.lib winsock.lib"
- else
- LIBS="coredll.lib corelibc.lib ws2.lib"
- fi
- # celib currently stuck at wce300 status
- #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib"
- LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\""
- LIBS_GUI="commctrl.lib commdlg.lib"
- else
- LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib"
- fi
+ LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib winspool.lib"
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
SHLIB_LD_LIBS='${LIBS}'
@@ -1013,7 +874,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
- if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then
+ if test "${TARGETCPU}" != "X86"; then
LDFLAGS_CONSOLE="-link ${lflags}"
LDFLAGS_WINDOW=${LDFLAGS_CONSOLE}
else
@@ -1101,6 +962,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
[Defined when cygwin/mingw ignores VOID define in winnt.h])
fi
+ AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],)
+
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
@@ -1146,13 +1009,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
#------------------------------------------------------------------------
AC_DEFUN([SC_WITH_TCL], [
- if test -d ../../tcl8.6$1/win; then
- TCL_BIN_DEFAULT=../../tcl8.6$1/win
+ if test -d ../../tcl8.7$1/win; then
+ TCL_BIN_DEFAULT=../../tcl8.7$1/win
else
- TCL_BIN_DEFAULT=../../tcl8.6/win
+ TCL_BIN_DEFAULT=../../tcl8.7/win
fi
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 binaries from DIR],
+ AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.7 binaries from DIR],
TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
@@ -1261,8 +1124,7 @@ AC_DEFUN([SC_TCL_CFG_ENCODING], [
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}")
else
- # Default encoding on windows is not "iso8859-1"
- AC_DEFINE(TCL_CFGVAL_ENCODING,"cp1252")
+ AC_DEFINE(TCL_CFGVAL_ENCODING,"utf-8")
fi
])
@@ -1317,3 +1179,126 @@ print("manifest needed")
AC_SUBST(VC_MANIFEST_EMBED_DLL)
AC_SUBST(VC_MANIFEST_EMBED_EXE)
])
+
+#------------------------------------------------------------------------
+# SC_CC_FOR_BUILD
+# For cross compiles, locate a C compiler that can generate native binaries.
+#
+# Arguments:
+# none
+#
+# Results:
+# Substitutes the following vars:
+# CC_FOR_BUILD
+# EXEEXT_FOR_BUILD
+#------------------------------------------------------------------------
+
+dnl Get a default for CC_FOR_BUILD to put into Makefile.
+AC_DEFUN([AX_CC_FOR_BUILD],
+[# Put a plausible default for CC_FOR_BUILD in Makefile.
+if test -z "$CC_FOR_BUILD"; then
+ if test "x$cross_compiling" = "xno"; then
+ CC_FOR_BUILD='$(CC)'
+ else
+ AC_MSG_CHECKING([for gcc])
+ AC_CACHE_VAL(ac_cv_path_cc, [
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/gcc 2> /dev/null` \
+ `ls -r $dir/gcc 2> /dev/null` ; do
+ if test x"$ac_cv_path_cc" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_cc=$j
+ break
+ fi
+ fi
+ done
+ done
+ ])
+ fi
+fi
+AC_SUBST(CC_FOR_BUILD)
+# Also set EXEEXT_FOR_BUILD.
+if test "x$cross_compiling" = "xno"; then
+ EXEEXT_FOR_BUILD='$(EXEEXT)'
+ OBJEXT_FOR_BUILD='$(OBJEXT)'
+else
+ OBJEXT_FOR_BUILD='.no'
+ AC_CACHE_CHECK([for build system executable suffix], bfd_cv_build_exeext,
+ [rm -f conftest*
+ echo 'int main () { return 0; }' > conftest.c
+ bfd_cv_build_exeext=
+ ${CC_FOR_BUILD} -o conftest conftest.c 1>&5 2>&5
+ for file in conftest.*; do
+ case $file in
+ *.c | *.o | *.obj | *.ilk | *.pdb) ;;
+ *) bfd_cv_build_exeext=`echo $file | sed -e s/conftest//` ;;
+ esac
+ done
+ rm -f conftest*
+ test x"${bfd_cv_build_exeext}" = x && bfd_cv_build_exeext=no])
+ EXEEXT_FOR_BUILD=""
+ test x"${bfd_cv_build_exeext}" != xno && EXEEXT_FOR_BUILD=${bfd_cv_build_exeext}
+fi
+AC_SUBST(EXEEXT_FOR_BUILD)])dnl
+AC_SUBST(OBJEXT_FOR_BUILD)])dnl
+
+
+
+#------------------------------------------------------------------------
+# SC_ZIPFS_SUPPORT
+# Locate a zip encoder installed on the system path, or none.
+#
+# Arguments:
+# none
+#
+# Results:
+# Substitutes the following vars:
+# ZIP_PROG
+# ZIP_PROG_OPTIONS
+# ZIP_PROG_VFSSEARCH
+# ZIP_INSTALL_OBJS
+#------------------------------------------------------------------------
+
+AC_DEFUN([SC_ZIPFS_SUPPORT], [
+ ZIP_PROG=""
+ ZIP_PROG_OPTIONS=""
+ ZIP_PROG_VFSSEARCH=""
+ ZIP_INSTALL_OBJS=""
+
+ AC_MSG_CHECKING([for zip])
+ AC_CACHE_VAL(ac_cv_path_zip, [
+ search_path=`echo ${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/zip 2> /dev/null` \
+ `ls -r $dir/zip 2> /dev/null` ; do
+ if test x"$ac_cv_path_zip" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_zip=$j
+ break
+ fi
+ fi
+ done
+ done
+ ])
+ if test -f "$ac_cv_path_zip" ; then
+ ZIP_PROG="$ac_cv_path_zip"
+ AC_MSG_RESULT([$ZIP_PROG])
+ ZIP_PROG_OPTIONS="-rq"
+ ZIP_PROG_VFSSEARCH="*"
+ AC_MSG_RESULT([Found INFO Zip in environment])
+ # Use standard arguments for zip
+ else
+ # It is not an error if an installed version of Zip can't be located.
+ # We can use the locally distributed minizip instead
+ ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}"
+ ZIP_PROG_OPTIONS="-o -r"
+ ZIP_PROG_VFSSEARCH="*"
+ ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}"
+ AC_MSG_RESULT([No zip found on PATH building minizip])
+ fi
+ AC_SUBST(ZIP_PROG)
+ AC_SUBST(ZIP_PROG_OPTIONS)
+ AC_SUBST(ZIP_PROG_VFSSEARCH)
+ AC_SUBST(ZIP_INSTALL_OBJS)
+])
diff --git a/win/tcl.rc b/win/tcl.rc
index 06024d4..3d125f2 100644
--- a/win/tcl.rc
+++ b/win/tcl.rc
@@ -7,19 +7,13 @@
//
// build-up the name suffix that defines the type of build this is.
//
-#if TCL_THREADS
-#define SUFFIX_THREADS "t"
-#else
-#define SUFFIX_THREADS ""
-#endif
-
#if DEBUG && !UNCHECKED
#define SUFFIX_DEBUG "g"
#else
#define SUFFIX_DEBUG ""
#endif
-#define SUFFIX SUFFIX_THREADS SUFFIX_DEBUG
+#define SUFFIX SUFFIX_DEBUG
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index 058b92a..a3914f1 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -15,17 +15,14 @@
*/
#include "tcl.h"
-#define WIN32_LEAN_AND_MEAN
-#define STRICT /* See MSDN Article Q83456 */
-#include <windows.h>
-#undef STRICT
-#undef WIN32_LEAN_AND_MEAN
-#include <locale.h>
-#include <stdlib.h>
-#include <tchar.h>
-#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7
+#if TCL_MAJOR_VERSION < 9
+# if defined(USE_TCL_STUBS)
+# error "Don't build with USE_TCL_STUBS!"
+# endif
+# if TCL_MINOR_VERSION < 7
# define Tcl_LibraryInitProc Tcl_PackageInitProc
# define Tcl_StaticLibrary Tcl_StaticPackage
+# endif
#endif
#ifdef TCL_TEST
@@ -33,12 +30,20 @@ extern Tcl_LibraryInitProc Tcltest_Init;
extern Tcl_LibraryInitProc Tcltest_SafeInit;
#endif /* TCL_TEST */
-#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES
+#if defined(STATIC_BUILD)
extern Tcl_LibraryInitProc Registry_Init;
extern Tcl_LibraryInitProc Dde_Init;
extern Tcl_LibraryInitProc Dde_SafeInit;
#endif
+#define WIN32_LEAN_AND_MEAN
+#define STRICT /* See MSDN Article Q83456 */
+#include <windows.h>
+#undef STRICT
+#undef WIN32_LEAN_AND_MEAN
+#include <locale.h>
+#include <stdlib.h>
+#include <tchar.h>
#if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS)
int _CRT_glob = 0;
#endif /* __GNUC__ || TCL_BROKEN_MAINARGS */
@@ -163,11 +168,11 @@ int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if ((Tcl_Init)(interp) == TCL_ERROR) {
+ if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
-#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES
+#if defined(STATIC_BUILD)
if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -210,8 +215,8 @@ Tcl_AppInit(
* user-specific startup file will be run under any conditions.
*/
- (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL,
- Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL,
+ Tcl_NewStringObj("~/tclshrc.tcl", TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
return TCL_OK;
}
@@ -273,8 +278,8 @@ setargv(
}
/* Make sure we don't call ckalloc through the (not yet initialized) stub table */
- #undef Tcl_Alloc
- #undef Tcl_DbCkalloc
+# undef Tcl_Alloc
+# undef Tcl_DbCkalloc
argSpace = (TCHAR *)ckalloc(size * sizeof(char *)
+ (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in
index 6ed06e2..776dcb0 100644
--- a/win/tclConfig.sh.in
+++ b/win/tclConfig.sh.in
@@ -23,9 +23,10 @@ TCL_CC='@CC@'
# -D flags for use with the C compiler.
TCL_DEFS='@DEFS@'
-# If TCL was built with debugging symbols, generated libraries contain
-# this string at the end of the library name (before the extension).
-TCL_DBGX=@TCL_DBGX@
+# TCL_DBGX used to be used to distinguish debug vs. non-debug builds.
+# This was a righteous pain so the core doesn't do that any more.
+# DEPRECATED, will be removed in Tcl 9!
+TCL_DBGX=''
# Default flags used in an optimized and debuggable build, respectively.
TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@'
@@ -41,6 +42,9 @@ TCL_SHARED_BUILD=@TCL_SHARED_BUILD@
# The name of the Tcl library (may be either a .a file or a shared library):
TCL_LIB_FILE='@TCL_LIB_FILE@'
+# The name of a zip containing the /library and /encodings (may be either a .zip file or a shared library):
+TCL_ZIP_FILE='@TCL_ZIP_FILE@'
+
# Flag to indicate whether shared libraries need export files.
TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@
@@ -77,7 +81,7 @@ TCL_SHLIB_LD='@SHLIB_LD@'
TCL_STLIB_LD='@STLIB_LD@'
# Either '$LIBS' (if dependent libraries should be included when linking
-# shared libraries) or an empty string. See Tcl's configure.in for more
+# shared libraries) or an empty string. See Tcl's configure.ac for more
# explanation.
TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@'
@@ -175,7 +179,3 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@'
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'
-
-# Flag, 1: we built Tcl with threads enabled, 0 we didn't
-TCL_THREADS=@TCL_THREADS@
-
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index d418b56..7c3d8a4 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -4,8 +4,8 @@
* This file contains the DLL entry point and other low-level bit bashing
* code that needs inline assembly.
*
- * Copyright (c) 1995-1996 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Scriptics Corporation.
+ * Copyright © 1995-1996 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.
@@ -25,14 +25,6 @@
static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
/*
- * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it
- */
-
-#if defined(_MSC_VER) && (_MSC_VER <= 1100) && defined (_M_IX86)
-#define cpuid __asm __emit 0fh __asm __emit 0a2h
-#endif
-
-/*
* The following declaration is for the VC++ DLL entry point.
*/
@@ -117,10 +109,8 @@ BOOL APIENTRY
DllMain(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
- LPVOID reserved) /* Not used. */
+ TCL_UNUSED(LPVOID))
{
- (void)reserved;
-
switch (reason) {
case DLL_PROCESS_ATTACH:
DisableThreadLibraryCalls(hInst);
@@ -187,40 +177,16 @@ TclWinInit(
GetVersionExW(&os);
/*
- * We no longer support Win32s or Win9x or Windows CE, so just in case
- * someone manages to get a runtime there, make sure they know that.
+ * We no longer support Win32s or Win9x or Windows CE or Windows XP, so just
+ * in case someone manages to get a runtime there, make sure they know that.
*/
if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) {
- Tcl_Panic("Windows NT is the only supported platform");
+ Tcl_Panic("Windows 7 is the minimum supported platform");
}
}
/*
- *----------------------------------------------------------------------
- *
- * TclWinGetPlatformId --
- *
- * Determines whether running under NT, 95, or Win32s, to allow runtime
- * conditional code.
- *
- * Results:
- * The return value is always:
- * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclWinGetPlatformId(void)
-{
- return VER_PLATFORM_WIN32_NT;
-}
-
-/*
*-------------------------------------------------------------------------
*
* TclWinNoBackslash --
@@ -289,26 +255,6 @@ TclWinEncodingsCleanup(void)
}
/*
- *---------------------------------------------------------------------------
- *
- * TclWinResetInterfaces --
- *
- * Called during finalization to reset us to a safe state for reuse.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-void
-TclWinResetInterfaces(void)
-{
-}
-
-/*
*--------------------------------------------------------------------
*
* TclWinDriveLetterForVolMountPoint
@@ -509,6 +455,8 @@ TclWinDriveLetterForVolMountPoint(
*---------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef Tcl_WinUtfToTChar
TCHAR *
Tcl_WinUtfToTChar(
const char *string, /* Source string in UTF-8. */
@@ -517,70 +465,10 @@ Tcl_WinUtfToTChar(
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
-#if TCL_UTF_MAX > 4
- Tcl_UniChar ch = 0;
- TCHAR *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(TCHAR)));
- wString = (TCHAR *) (Tcl_DStringValue(dsPtr) + oldLength);
-
- w = wString;
- p = string;
- end = string + len - 4;
- while (p < end) {
- p += TclUtfToUniChar(p, &ch);
- if (ch > 0xFFFF) {
- *w++ = (WCHAR) (0xD800 + ((ch -= 0x10000) >> 10));
- *w++ = (WCHAR) (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) (0xD800 + ((ch -= 0x10000) >> 10));
- *w++ = (WCHAR) (0xDC00 | (ch & 0x3FF));
- } else {
- *w++ = ch;
- }
- }
- *w = '\0';
- Tcl_DStringSetLength(dsPtr,
- oldLength + ((char *) w - (char *) wString));
-
- return wString;
-#else
- return (TCHAR *)Tcl_UtfToUniCharDString(string, len, dsPtr);
-#endif
+ return (TCHAR *)Tcl_UtfToWCharDString(string, len, dsPtr);
}
-
+#undef Tcl_WinTCharToUtf
char *
Tcl_WinTCharToUtf(
const TCHAR *string, /* Source string in Unicode. */
@@ -589,52 +477,10 @@ Tcl_WinTCharToUtf(
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
-#if TCL_UTF_MAX > 4
- const WCHAR *w, *wEnd;
- char *p, *result;
- int oldLength, blen = 1;
-#endif
-
Tcl_DStringInit(dsPtr);
- if (!string) {
- return NULL;
- }
- if (len < 0) {
- len = (int)wcslen((WCHAR *)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 *)string + len;
- for (w = (WCHAR *)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_WCharToUtfDString((WCHAR *)string, len >> 1, dsPtr);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*------------------------------------------------------------------------
@@ -656,14 +502,14 @@ Tcl_WinTCharToUtf(
int
TclWinCPUID(
- unsigned int index, /* Which CPUID value to retrieve. */
- unsigned int *regsPtr) /* Registers after the CPUID. */
+ int index, /* Which CPUID value to retrieve. */
+ int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
#if defined(HAVE_INTRIN_H) && defined(_WIN64) && defined(HAVE_CPUID)
- __cpuid((int *)regsPtr, (int)index);
+ __cpuid((int *)regsPtr, index);
status = TCL_OK;
#elif defined(__GNUC__) && defined(HAVE_CPUID)
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 6308930..ecdd03a 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -4,7 +4,7 @@
* Channel drivers for Windows channels based on files, command pipes and
* TCP sockets.
*
- * 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.
@@ -25,7 +25,8 @@
#define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2)
/*
- * The following structure contains per-instance data for a file based channel.
+ * The following structure contains per-instance data for a file based
+ * channel.
*/
typedef struct FileInfo {
@@ -43,7 +44,7 @@ typedef struct FileInfo {
* pending on the channel. */
} FileInfo;
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* List of all file channels currently open.
*/
@@ -58,7 +59,7 @@ static Tcl_ThreadDataKey dataKey;
* events are generated.
*/
-typedef struct FileEvent {
+typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
FileInfo *infoPtr; /* Pointer to file info structure. Note that
@@ -75,8 +76,6 @@ static int FileBlockProc(ClientData instanceData, int mode);
static void FileChannelExitHandler(ClientData clientData);
static void FileCheckProc(ClientData clientData, int flags);
static int FileCloseProc(ClientData instanceData,
- Tcl_Interp *interp);
-static int FileClose2Proc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int FileEventProc(Tcl_Event *evPtr, int flags);
static int FileGetHandleProc(ClientData instanceData,
@@ -86,16 +85,18 @@ static int FileInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int FileOutputProc(ClientData instanceData,
const char *buf, int toWrite, int *errorCode);
+#ifndef TCL_NO_DEPRECATED
static int FileSeekProc(ClientData instanceData, long offset,
int mode, int *errorCode);
-static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCode);
+#endif
+static long long FileWideSeekProc(ClientData instanceData,
+ long long offset, int mode, int *errorCode);
static void FileSetupProc(ClientData clientData, int flags);
static void FileWatchProc(ClientData instanceData, int mask);
static void FileThreadActionProc(ClientData instanceData,
int action);
static int FileTruncateProc(ClientData instanceData,
- Tcl_WideInt length);
+ long long length);
static DWORD FileGetType(HANDLE handle);
static int NativeIsComPort(const WCHAR *nativeName);
static Tcl_Channel OpenFileChannel(HANDLE handle, char *channelName,
@@ -108,15 +109,19 @@ static Tcl_Channel OpenFileChannel(HANDLE handle, char *channelName,
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- FileCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
+#ifndef TCL_NO_DEPRECATED
FileSeekProc, /* Seek proc. */
+#else
+ NULL,
+#endif
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Set up the notifier to watch the channel. */
FileGetHandleProc, /* Get an OS handle from channel. */
- FileClose2Proc, /* close2proc. */
+ FileCloseProc, /* close2proc. */
FileBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
@@ -124,6 +129,14 @@ static const Tcl_ChannelType fileChannelType = {
FileThreadActionProc, /* Thread action proc. */
FileTruncateProc /* Truncate proc. */
};
+
+/*
+ * General useful clarification macros.
+ */
+
+#define SET_FLAG(var, flag) ((var) |= (flag))
+#define CLEAR_FLAG(var, flag) ((var) &= ~(flag))
+#define TEST_FLAG(value, flag) (((value) & (flag)) != 0)
/*
*----------------------------------------------------------------------
@@ -145,7 +158,7 @@ static ThreadSpecificData *
FileInit(void)
{
ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -175,10 +188,8 @@ FileInit(void)
static void
FileChannelExitHandler(
- ClientData clientData) /* Old window proc */
+ TCL_UNUSED(ClientData))
{
- (void)clientData;
-
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
}
@@ -201,15 +212,14 @@ FileChannelExitHandler(
void
FileSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
FileInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)data;
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return;
}
@@ -245,15 +255,14 @@ FileSetupProc(
static void
FileCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
FileEvent *evPtr;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)data;
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return;
}
@@ -264,8 +273,8 @@ FileCheckProc(
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
- if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
- infoPtr->flags |= FILE_PENDING;
+ if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) {
+ SET_FLAG(infoPtr->flags, FILE_PENDING);
evPtr = (FileEvent *)ckalloc(sizeof(FileEvent));
evPtr->header.proc = FileEventProc;
evPtr->infoPtr = infoPtr;
@@ -305,7 +314,7 @@ FileEventProc(
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return 0;
}
@@ -319,7 +328,7 @@ FileEventProc(
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (fileEvPtr->infoPtr == infoPtr) {
- infoPtr->flags &= ~(FILE_PENDING);
+ CLEAR_FLAG(infoPtr->flags, FILE_PENDING);
Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
break;
}
@@ -359,9 +368,9 @@ FileBlockProc(
*/
if (mode == TCL_MODE_NONBLOCKING) {
- infoPtr->flags |= FILE_ASYNC;
+ SET_FLAG(infoPtr->flags, FILE_ASYNC);
} else {
- infoPtr->flags &= ~(FILE_ASYNC);
+ CLEAR_FLAG(infoPtr->flags, FILE_ASYNC);
}
return 0;
}
@@ -369,7 +378,7 @@ FileBlockProc(
/*
*----------------------------------------------------------------------
*
- * FileCloseProc/FileClose2Proc --
+ * FileCloseProc --
*
* Closes the IO channel.
*
@@ -385,13 +394,17 @@ FileBlockProc(
static int
FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
- Tcl_Interp *interp) /* Not used. */
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
{
FileInfo *fileInfoPtr = (FileInfo *)instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
- (void)interp;
+
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
/*
* Remove the file from the watch list.
@@ -410,7 +423,7 @@ FileCloseProc(
&& (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
if (CloseHandle(fileInfoPtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
errorCode = errno;
}
}
@@ -437,18 +450,6 @@ FileCloseProc(
ckfree(fileInfoPtr);
return errorCode;
}
-
-static int
-FileClose2Proc(
- ClientData instanceData, /* Pointer to FileInfo structure. */
- Tcl_Interp *interp, /* Not used. */
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return FileCloseProc(instanceData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -467,7 +468,7 @@ FileClose2Proc(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
ClientData instanceData, /* File state. */
@@ -493,24 +494,24 @@ FileSeekProc(
*/
oldPosHigh = 0;
- oldPos = (int)SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
- if (oldPos == (LONG)INVALID_SET_FILE_POINTER) {
+ oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
+ if (oldPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
- TclWinConvertError(winError);
+ Tcl_WinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
}
newPosHigh = (offset < 0 ? -1 : 0);
- newPos = (int)SetFilePointer(infoPtr->handle, offset, &newPosHigh, moveMethod);
- if (newPos == (LONG)INVALID_SET_FILE_POINTER) {
+ newPos = SetFilePointer(infoPtr->handle, offset, &newPosHigh, moveMethod);
+ if (newPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
- TclWinConvertError(winError);
+ Tcl_WinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
@@ -527,6 +528,7 @@ FileSeekProc(
}
return (int) newPos;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -546,10 +548,10 @@ FileSeekProc(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
FileWideSeekProc(
ClientData instanceData, /* File state. */
- Tcl_WideInt offset, /* Offset to seek to. */
+ long long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
@@ -566,19 +568,20 @@ FileWideSeekProc(
moveMethod = FILE_END;
}
- newPosHigh = Tcl_WideAsLong(offset >> 32);
- newPos = (int)SetFilePointer(infoPtr->handle, Tcl_WideAsLong(offset),
+ newPosHigh = (LONG)(offset >> 32);
+ newPos = SetFilePointer(infoPtr->handle, (LONG)offset,
&newPosHigh, moveMethod);
- if (newPos == (LONG)INVALID_SET_FILE_POINTER) {
+ if (newPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
- TclWinConvertError(winError);
+ Tcl_WinConvertError(winError);
*errorCodePtr = errno;
return -1;
}
}
- return (((Tcl_WideInt)((unsigned)newPos)) | (Tcl_LongAsWide(newPosHigh) << 32));
+ return (((long long)((unsigned)newPos))
+ | ((long long)newPosHigh << 32));
}
/*
@@ -600,7 +603,7 @@ FileWideSeekProc(
static int
FileTruncateProc(
ClientData instanceData, /* File state. */
- Tcl_WideInt length) /* Length to truncate at. */
+ long long length) /* Length to truncate at. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
@@ -610,11 +613,12 @@ FileTruncateProc(
*/
oldPosHigh = 0;
- oldPos = (int)SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
- if (oldPos == (LONG)INVALID_SET_FILE_POINTER) {
+ oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
+ if (oldPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
+
if (winError != NO_ERROR) {
- TclWinConvertError(winError);
+ Tcl_WinConvertError(winError);
return errno;
}
}
@@ -623,13 +627,14 @@ FileTruncateProc(
* Move to where we want to truncate
*/
- newPosHigh = Tcl_WideAsLong(length >> 32);
- newPos = (int)SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length),
+ newPosHigh = (LONG)(length >> 32);
+ newPos = SetFilePointer(infoPtr->handle, (LONG)length,
&newPosHigh, FILE_BEGIN);
- if (newPos == (LONG)INVALID_SET_FILE_POINTER) {
+ if (newPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
+
if (winError != NO_ERROR) {
- TclWinConvertError(winError);
+ Tcl_WinConvertError(winError);
return errno;
}
}
@@ -640,7 +645,7 @@ FileTruncateProc(
*/
if (!SetEndOfFile(infoPtr->handle)) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return errno;
}
@@ -684,9 +689,9 @@ FileInputProc(
*errorCode = 0;
/*
- * TODO: This comment appears to be out of date. We *do* have a
- * console driver, over in tclWinConsole.c. After some Windows
- * developer confirms, this comment should be revised.
+ * TODO: This comment appears to be out of date. We *do* have a console
+ * driver, over in tclWinConsole.c. After some Windows developer confirms,
+ * this comment should be revised.
*
* Note that we will block on reads from a console buffer until a full
* line has been entered. The only way I know of to get around this is to
@@ -700,7 +705,7 @@ FileInputProc(
return (int)bytesRead;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
*errorCode = errno;
if (errno == EPIPE) {
return 0;
@@ -743,13 +748,13 @@ FileOutputProc(
* seek to the end of the file before writing the current buffer.
*/
- if (infoPtr->flags & FILE_APPEND) {
+ if (TEST_FLAG(infoPtr->flags, FILE_APPEND)) {
SetFilePointer(infoPtr->handle, 0, NULL, FILE_END);
}
if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
&bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
*errorCode = errno;
return -1;
}
@@ -820,12 +825,12 @@ FileGetHandleProc(
{
FileInfo *infoPtr = (FileInfo *)instanceData;
- if (direction & infoPtr->validMask) {
- *handlePtr = (ClientData) infoPtr->handle;
- return TCL_OK;
- } else {
+ if (!TEST_FLAG(direction, infoPtr->validMask)) {
return TCL_ERROR;
}
+
+ *handlePtr = (ClientData) infoPtr->handle;
+ return TCL_OK;
}
/*
@@ -865,10 +870,10 @@ TclpOpenFileChannel(
nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"",
- TclGetString(pathPtr), "\": filename is invalid on this platform",
- NULL);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open \"%s\": filename is invalid on this platform",
+ TclGetString(pathPtr)));
}
return NULL;
}
@@ -916,39 +921,40 @@ TclpOpenFileChannel(
}
/*
- * [2413550] Avoid double-open of serial ports on Windows
- * Special handling for Windows serial ports by a "name-hint"
- * to directly open it with the OVERLAPPED flag set.
+ * [2413550] Avoid double-open of serial ports on Windows. Special
+ * handling for Windows serial ports by a "name-hint" to directly open it
+ * with the OVERLAPPED flag set.
*/
- if( NativeIsComPort(nativeName) ) {
-
+ if (NativeIsComPort(nativeName)) {
handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open serial \"",
- TclGetString(pathPtr), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_WinConvertError(GetLastError());
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't open serial \"%s\": %s",
+ TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
/*
- * For natively-named Windows serial ports we are done.
- */
+ * For natively-named Windows serial ports we are done.
+ */
+
channel = TclWinOpenSerialChannel(handle, channelName,
channelPermissions);
return channel;
}
+
/*
* If the file is being created, get the file attributes from the
* permissions argument, else use the existing file attributes.
*/
- if (mode & O_CREAT) {
- if (permissions & S_IWRITE) {
+ if (TEST_FLAG(mode, O_CREAT)) {
+ if (TEST_FLAG(permissions, S_IWRITE)) {
flags = FILE_ATTRIBUTE_NORMAL;
} else {
flags = FILE_ATTRIBUTE_READONLY;
@@ -977,10 +983,11 @@ TclpOpenFileChannel(
DWORD err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
- err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
+ err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS
+ : ERROR_FILE_NOT_FOUND;
}
- TclWinConvertError(err);
- if (interp != (Tcl_Interp *) NULL) {
+ Tcl_WinConvertError(err);
+ if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
@@ -993,9 +1000,9 @@ TclpOpenFileChannel(
switch (FileGetType(handle)) {
case FILE_TYPE_SERIAL:
/*
- * Natively named serial ports "com1-9", "\\\\.\\comXX" are
- * already done with the code above.
- * Here we handle all other serial port names.
+ * Natively named serial ports "com1-9", "\\\\.\\comXX" are already
+ * done with the code above. Here we handle all other serial port
+ * names.
*
* Reopen channel for OVERLAPPED operation. Normally this shouldn't
* fail, because the channel exists.
@@ -1003,8 +1010,8 @@ TclpOpenFileChannel(
handle = TclWinSerialOpen(handle, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
- if (interp != (Tcl_Interp *) NULL) {
+ Tcl_WinConvertError(GetLastError());
+ if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't reopen serial \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
@@ -1019,10 +1026,10 @@ TclpOpenFileChannel(
channelPermissions);
break;
case FILE_TYPE_PIPE:
- if (channelPermissions & TCL_READABLE) {
+ if (TEST_FLAG(channelPermissions, TCL_READABLE)) {
readFile = TclWinMakeFile(handle);
}
- if (channelPermissions & TCL_WRITABLE) {
+ if (TEST_FLAG(channelPermissions, TCL_WRITABLE)) {
writeFile = TclWinMakeFile(handle);
}
channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL);
@@ -1031,7 +1038,8 @@ TclpOpenFileChannel(
case FILE_TYPE_DISK:
case FILE_TYPE_UNKNOWN:
channel = OpenFileChannel(handle, channelName,
- channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0);
+ channelPermissions,
+ TEST_FLAG(mode, O_APPEND) ? FILE_APPEND : 0);
break;
default:
@@ -1084,7 +1092,7 @@ Tcl_MakeFileChannel(
TclFile readFile = NULL, writeFile = NULL;
BOOL result;
- if (mode == 0) {
+ if ((mode & (TCL_READABLE|TCL_WRITABLE)) == 0) {
return NULL;
}
@@ -1096,10 +1104,10 @@ Tcl_MakeFileChannel(
channel = TclWinOpenConsoleChannel(handle, channelName, mode);
break;
case FILE_TYPE_PIPE:
- if (mode & TCL_READABLE) {
+ if (TEST_FLAG(mode, TCL_READABLE)) {
readFile = TclWinMakeFile(handle);
}
- if (mode & TCL_WRITABLE) {
+ if (TEST_FLAG(mode, TCL_WRITABLE)) {
writeFile = TclWinMakeFile(handle);
}
channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL);
@@ -1319,7 +1327,7 @@ TclpGetDefaultStdChannel(
*/
if (Tcl_SetChannelOption(NULL,channel,"-translation","auto")!=TCL_OK ||
- Tcl_SetChannelOption(NULL,channel,"-eofchar","\032 {}")!=TCL_OK ||
+ Tcl_SetChannelOption(NULL,channel,"-eofchar","\x1A {}")!=TCL_OK ||
Tcl_SetChannelOption(NULL,channel,"-buffering",bufMode)!=TCL_OK) {
Tcl_Close(NULL, channel);
return (Tcl_Channel) NULL;
@@ -1367,7 +1375,7 @@ OpenFileChannel(
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
- return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
+ return ((permissions & (TCL_READABLE|TCL_WRITABLE|TCL_EXCEPTION))==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
@@ -1380,7 +1388,7 @@ OpenFileChannel(
*/
infoPtr->nextPtr = NULL;
- infoPtr->validMask = permissions;
+ infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE|TCL_EXCEPTION);
infoPtr->watchMask = 0;
infoPtr->flags = appendMode;
infoPtr->handle = handle;
@@ -1396,7 +1404,7 @@ OpenFileChannel(
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\x1A {}");
return infoPtr->channel;
}
@@ -1462,7 +1470,7 @@ FileThreadActionProc(
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- FileInfo *infoPtr = ( FileInfo *)instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
@@ -1546,10 +1554,11 @@ FileGetType(
*
* NativeIsComPort --
*
- * Determines if a path refers to a Windows serial port.
- * A simple and efficient solution is to use a "name hint" to detect
- * COM ports by their filename instead of resorting to a syscall
- * to detect serialness after the fact.
+ * Determines if a path refers to a Windows serial port. A simple and
+ * efficient solution is to use a "name hint" to detect COM ports by
+ * their filename instead of resorting to a syscall to detect serialness
+ * after the fact.
+ *
* The following patterns cover common serial port names:
* COM[1-9]
* \\.\COM[0-9]+
@@ -1565,18 +1574,18 @@ NativeIsComPort(
const WCHAR *nativePath) /* Path of file to access, native encoding. */
{
const WCHAR *p = (const WCHAR *) nativePath;
- int i, len = (int)wcslen(p);
+ size_t i, len = wcslen(p);
/*
* 1. Look for com[1-9]:?
*/
- if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) {
+ if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) {
/*
- * The 4th character must be a digit 1..9
- */
+ * The 4th character must be a digit 1..9
+ */
- if ( (p[3] < L'1') || (p[3] > L'9') ) {
+ if ((p[3] < '1') || (p[3] > '9')) {
return 0;
}
return 1;
@@ -1588,11 +1597,11 @@ NativeIsComPort(
if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) {
/*
- * Charaters 8..end must be a digits 0..9
- */
+ * Charaters 8..end must be a digits 0..9
+ */
- for ( i=7; i<len; i++ ) {
- if ( (p[i] < '0') || (p[i] > '9') ) {
+ for (i=7; i<len; i++) {
+ if ((p[i] < '0') || (p[i] > '9')) {
return 0;
}
}
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index facdb01..47aba5d 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -2,168 +2,286 @@
* tclWinConsole.c --
*
* This file implements the Windows-specific console functions, and the
- * "console" channel driver.
+ * "console" channel driver. Windows 7 or later required.
*
- * Copyright (c) 1999 by Scriptics Corp.
+ * 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.
*/
-#include "tclWinInt.h"
+#ifdef TCL_CONSOLE_DEBUG
+#undef NDEBUG /* Enable asserts */
+#endif
-/*
- * The following variable is used to tell whether this module has been
- * initialized.
- */
-
-static int initialized = 0;
+#include "tclWinInt.h"
+#include <assert.h>
+#include <ctype.h>
/*
- * The consoleMutex locks around access to the initialized variable, and it is
- * used to protect background threads from being terminated while they are
- * using APIs that hold locks.
+ * A general note on the design: The console channel driver differs from
+ * most other drivers in the following respects:
+ *
+ * - There can be at most 3 console handles at any time since Windows does
+ * support allocation of more than one console (with three handles
+ * corresponding to stdin, stdout, stderr)
+ *
+ * - Consoles are created / inherited at process startup. There is currently
+ * no way in Tcl to programmatically create a console. Even if these were
+ * added the above Windows limitation would still apply.
+ *
+ * - Unlike files, sockets etc. where there is a one-to-one
+ * correspondence between Tcl channels and operating system handles,
+ * std* channels are shared amongst threads which means there can be
+ * multiple Tcl channels corresponding to a single console handle.
+ *
+ * - Even with multiple threads, more than one file event handler is
+ * unlikely. It does not make sense for multiple threads to register
+ * handlers for stdin because the input would be randomly fragmented amongst
+ * the threads.
+ *
+ * Various design factors are driven by the above, e.g. use of lists instead
+ * of hash tables (at most 3 console handles) and use of global instead of
+ * per thread queues which simplifies lock management particularly because
+ * thread-console relation is not one-one and is likely more performant as
+ * well with fewer locks needing to be obtained.
+ *
+ * Some additional design notes/reminders for the future:
+ *
+ * Aligned, synchronous reads are done directly by interpreter thread.
+ * Unaligned or asynchronous reads are done through the reader thread.
+ *
+ * The reader thread does not read ahead. That is, it will not post a read
+ * until some interpreter thread is actually requesting a read. This is
+ * because an interpreter may (for example) turn off echo for passwords and
+ * the read ahead would come in the way of that.
+ *
+ * If multiple threads are reading from stdin, the input is sprayed in
+ * random fashion. This is not good application design and hence no plan to
+ * address this (not clear what should be done even in theory)
+ *
+ * For output, we do not restrict all output to the console writer threads.
+ * See ConsoleOutputProc for the conditions.
+ *
+ * Locks are never held when calling the ReadConsole/WriteConsole API's
+ * since they may block.
*/
-TCL_DECLARE_MUTEX(consoleMutex)
+static int gInitialized = 0;
/*
- * Bit masks used in the flags field of the ConsoleInfo structure below.
+ * Permit CONSOLE_BUFFER_SIZE to be defined on build command for stress test.
+ *
+ * In theory, at least sizeof(WCHAR) but note the Tcl channel bug
+ * https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c
+ * will cause failures in test suite if close to max input line in the suite.
*/
-
-#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */
-#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */
+#ifndef CONSOLE_BUFFER_SIZE
+#define CONSOLE_BUFFER_SIZE 8000 /* In bytes */
+#endif
/*
- * Bit masks used in the sharedFlags field of the ConsoleInfo structure below.
+ * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1]
+ * and bufPtr[0]:bufPtr[length - (size-start)].
*/
-
-#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */
-#define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader
- * thread. */
-
-#define CONSOLE_BUFFER_SIZE (8*1024)
+typedef struct RingBuffer {
+ char *bufPtr; /* Pointer to buffer storage */
+ Tcl_Size capacity; /* Size of the buffer in RingBufferChar */
+ Tcl_Size start; /* Start of the data within the buffer. */
+ Tcl_Size length; /* Number of RingBufferChar*/
+} RingBuffer;
+#define RingBufferLength(ringPtr_) ((ringPtr_)->length)
+#define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity)
+#define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_))
/*
- * Structure containing handles associated with one of the special console
- * threads.
+ * The Win32 console API does not support non-blocking I/O in any form. Thus
+ * the actual calls are made on a separate thread. Moreover, separate
+ * threads are needed for each handle because (for example) blocking on user
+ * input on stdin should not prevent output to stdout when non-blocking i/o
+ * is configured at the script level.
+ *
+ * In the input (e.g. stdin) case, the console stdin thread is the producer
+ * writing to the buffer ring buffer. The Tcl interpreter threads are the
+ * consumer. For the output (e.g. stdout/stderr) case, the Tcl interpreter
+ * are the producers while the console stdout/stderr threads are the
+ * consumers.
+ *
+ * Consoles are identified purely by handles and multiple threads may open
+ * them (as stdin/stdout/stderr are shared).
+ *
+ * Note on reference counting - a ConsoleHandleInfo instance has multiple
+ * references to it - one each from every channel that is attached to it
+ * plus one from the console thread itself which also serves as the reference
+ * from gConsoleHandleInfoList.
*/
-
-typedef struct ConsoleThreadInfo {
- HANDLE thread; /* Handle to reader or writer thread. */
- HANDLE readyEvent; /* Manual-reset event to signal _to_ the main
- * thread when the worker thread has finished
- * waiting for its normal work to happen. */
- TclPipeThreadInfo *TI; /* Thread info structure of writer and reader. */
-} ConsoleThreadInfo;
+typedef struct ConsoleHandleInfo {
+ struct ConsoleHandleInfo *nextPtr; /* Process-global list of consoles */
+ HANDLE console; /* Console handle */
+ HANDLE consoleThread; /* Handle to thread doing actual i/o on the console */
+ SRWLOCK lock; /* Controls access to this structure.
+ * Cheaper than CRITICAL_SECTION but note does not
+ * support recursive locks or Try* style attempts.*/
+ CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */
+ CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */
+ RingBuffer buffer; /* Buffer for data transferred between console
+ * threads and Tcl threads. For input consoles,
+ * written by the console thread and read by Tcl
+ * threads. The converse for output threads */
+ DWORD initMode; /* Initial console mode. */
+ DWORD lastError; /* An error caused by the last background
+ * operation. Set to 0 if no error has been
+ * detected. */
+ int numRefs; /* See comments above */
+ int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE
+ * for output. Only one or the other can be set. */
+ int flags;
+#define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */
+} ConsoleHandleInfo;
/*
* This structure describes per-instance data for a console based channel.
+ *
+ * Note on locking - this structure has no locks because it is accessed
+ * only from the thread owning channel EXCEPT when a console traverses it
+ * looking for a channel that is watching for events on the console. Even
+ * in that case, no locking is required because that access is only under
+ * the gConsoleLock lock which prevents the channel from being removed from
+ * the gWatchingChannelList which in turn means it will not be deallocated
+ * from under the console thread. Access to individual fields does not need
+ * to be controlled because
+ * - the console thread does not write to any fields
+ * - changes to the nextWatchingChannelPtr field
+ * - changes to other fields do not matter because after being read for
+ * queueing events, they are verified again when the event is received
+ * in the interpreter thread (since they could have changed anyways while
+ * the event was in-flight on the event queue)
+ *
+ * Note on reference counting - a structure instance may be referenced from
+ * three places:
+ * - the Tcl channel subsystem. This reference is created when on channel
+ * opening and dropped on channel close. This also covers the reference
+ * from gWatchingChannelList since queueing / dequeuing from that list
+ * happens in conjunction with channel operations.
+ * - the Tcl event queue entries. This reference is added when the event
+ * is queued and dropped on receipt.
*/
-
-typedef struct ConsoleInfo {
- HANDLE handle;
- int type;
- struct ConsoleInfo *nextPtr;/* Pointer to next registered console. */
+typedef struct ConsoleChannelInfo {
+ HANDLE handle; /* Console handle */
+ Tcl_ThreadId threadId; /* Id of owning thread */
+ struct ConsoleChannelInfo
+ *nextWatchingChannelPtr; /* Pointer to next channel watching events. */
Tcl_Channel channel; /* Pointer to channel structure. */
- int validMask; /* OR'ed combination of TCL_READABLE,
+ DWORD initMode; /* Initial console mode. */
+ int numRefs; /* See comments above */
+ int permissions; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
int watchMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
- int flags; /* State flags, see above for a list. */
- Tcl_ThreadId threadId; /* Thread to which events should be reported.
- * This value is used by the reader/writer
- * threads. */
- ConsoleThreadInfo writer; /* A specialized thread for handling
- * asynchronous writes to the console; the
- * waiting starts when a control event is sent,
- * and a reset event is sent back to the main
- * thread when the write is done. */
- ConsoleThreadInfo reader; /* A specialized thread for handling
- * asynchronous reads from the console; the
- * waiting starts when a control event is sent,
- * and a reset event is sent back to the main
- * thread when input is available. */
- DWORD writeError; /* An error caused by the last background
- * write. Set to 0 if no error has been
- * detected. This word is shared with the
- * writer thread so access must be
- * synchronized with the writable object. */
- char *writeBuf; /* Current background output buffer. Access is
- * synchronized with the writable object. */
- int writeBufLen; /* Size of write buffer. Access is
- * synchronized with the writable object. */
- int toWrite; /* Current amount to be written. Access is
- * synchronized with the writable object. */
- int readFlags; /* Flags that are shared with the reader
- * thread. Access is synchronized with the
- * readable object. */
- int bytesRead; /* Number of bytes in the buffer. */
- int offset; /* Number of bytes read out of the buffer. */
- char buffer[CONSOLE_BUFFER_SIZE];
- /* Data consumed by reader thread. */
-} ConsoleInfo;
-
-typedef struct ThreadSpecificData {
- /*
- * The following pointer refers to the head of the list of consoles that
- * are being watched for file events.
- */
-
- ConsoleInfo *firstConsolePtr;
-} ThreadSpecificData;
-
-static Tcl_ThreadDataKey dataKey;
+ int flags; /* State flags */
+#define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */
+#define CONSOLE_ASYNC 0x0002 /* Channel is non-blocking. */
+#define CONSOLE_READ_OPS 0x0004 /* Channel supports read-related ops. */
+} ConsoleChannelInfo;
/*
* The following structure is what is added to the Tcl event queue when
* console events are generated.
*/
-typedef struct ConsoleEvent {
- Tcl_Event header; /* Information that is standard for all
- * events. */
- ConsoleInfo *infoPtr; /* Pointer to console info structure. Note
- * that we still have to verify that the
- * console exists before dereferencing this
- * pointer. */
+typedef struct {
+ Tcl_Event header; /* Information that is standard for all events. */
+ ConsoleChannelInfo *chanInfoPtr; /* Pointer to console info structure. Note
+ * that we still have to verify that the
+ * console exists before dereferencing this
+ * pointer. */
} ConsoleEvent;
/*
* Declarations for functions used only in this file.
*/
-static int ConsoleBlockModeProc(ClientData instanceData,
- int mode);
-static void ConsoleCheckProc(ClientData clientData, int flags);
-static int ConsoleCloseProc(ClientData instanceData,
- Tcl_Interp *interp);
-static int ConsoleClose2Proc(ClientData instanceData,
- Tcl_Interp *interp, int flags);
-static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
-static void ConsoleExitHandler(ClientData clientData);
-static int ConsoleGetHandleProc(ClientData instanceData,
- int direction, ClientData *handlePtr);
-static void ConsoleInit(void);
-static int ConsoleInputProc(ClientData instanceData, char *buf,
- int toRead, int *errorCode);
-static int ConsoleOutputProc(ClientData instanceData,
- const char *buf, int toWrite, int *errorCode);
+static int ConsoleBlockModeProc(ClientData instanceData, int mode);
+static void ConsoleCheckProc(ClientData clientData, int flags);
+static int ConsoleCloseProc(ClientData instanceData,
+ Tcl_Interp *interp, int flags);
+static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
+static void ConsoleExitHandler(ClientData clientData);
+static int ConsoleGetHandleProc(ClientData instanceData,
+ int direction, ClientData *handlePtr);
+static int ConsoleGetOptionProc(ClientData instanceData,
+ Tcl_Interp *interp, const char *optionName,
+ Tcl_DString *dsPtr);
+static void ConsoleInit(void);
+static int ConsoleInputProc(ClientData instanceData, char *buf,
+ int toRead, int *errorCode);
+static int ConsoleOutputProc(ClientData instanceData,
+ const char *buf, int toWrite, int *errorCode);
+static int ConsoleSetOptionProc(ClientData instanceData,
+ Tcl_Interp *interp, const char *optionName,
+ const char *value);
+static void ConsoleSetupProc(ClientData clientData, int flags);
+static void ConsoleWatchProc(ClientData instanceData, int mask);
+static void ProcExitHandler(ClientData clientData);
+static void ConsoleThreadActionProc(ClientData instanceData, int action);
+static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer,
+ Tcl_Size nChars, Tcl_Size *nCharsReadPtr);
+static DWORD WriteConsoleChars(HANDLE hConsole,
+ const WCHAR *lpBuffer, Tcl_Size nChars,
+ Tcl_Size *nCharsWritten);
+static void RingBufferInit(RingBuffer *ringPtr, Tcl_Size capacity);
+static void RingBufferClear(RingBuffer *ringPtr);
+static Tcl_Size RingBufferIn(RingBuffer *ringPtr, const char *srcPtr,
+ Tcl_Size srcLen, int partialCopyOk);
+static Tcl_Size RingBufferOut(RingBuffer *ringPtr, char *dstPtr,
+ Tcl_Size dstCapacity, int partialCopyOk);
+static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle,
+ int permissions);
+static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *);
static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
-static void ConsoleSetupProc(ClientData clientData, int flags);
-static void ConsoleWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI ConsoleWriterThread(LPVOID arg);
-static void ProcExitHandler(ClientData clientData);
-static int WaitForRead(ConsoleInfo *infoPtr, int blocking);
-static void ConsoleThreadActionProc(ClientData instanceData,
- int action);
-static BOOL ReadConsoleBytes(HANDLE hConsole, LPVOID lpBuffer,
- DWORD nbytes, LPDWORD nbytesread);
-static BOOL WriteConsoleBytes(HANDLE hConsole,
- const void *lpBuffer, DWORD nbytes,
- LPDWORD nbyteswritten);
+static void NudgeWatchers(HANDLE consoleHandle);
+#ifndef NDEBUG
+static int RingBufferCheck(const RingBuffer *ringPtr);
+#endif
+
+/*
+ * Static data.
+ */
+
+typedef struct {
+ /* Currently this struct is only used to detect thread initialization */
+ int notUsed; /* Dummy field */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * All access to static data is controlled through a single process-wide
+ * lock. A process can have only a single console at a time, with three
+ * handles for stdin, stdout and stderr. Creation/destruction of consoles is
+ * a relatively rare event (currently only possible during process start),
+ * the number of consoles (as opposed to channels) is small (only stdin,
+ * stdout and stderr), and contention low. More finer-grained locking would
+ * likely not only complicate implementation but be slower due to multiple
+ * locks being held. Note console channels also differ from other Tcl
+ * channel types in that the channel<->OS descriptor mapping is not one-to-one.
+ */
+SRWLOCK gConsoleLock;
+
+
+/* Process-wide list of console handles. Access control through gConsoleLock */
+static ConsoleHandleInfo *gConsoleHandleInfoList;
+
+/*
+ * Process-wide list of channels that are listening for events. Again access
+ * control through gConsoleLock. Common list for all threads is simplifies
+ * locking and bookkeeping and is workable because in practice multiple
+ * threads are very unlikely to be all waiting on stdin (not workable
+ * because input would be randomly distributed to threads)
+ */
+static ConsoleChannelInfo *gWatchingChannelList;
/*
* This structure describes the channel type structure for command console
@@ -171,82 +289,317 @@ static BOOL WriteConsoleBytes(HANDLE hConsole,
*/
static const Tcl_ChannelType consoleChannelType = {
- "console", /* Type name. */
- TCL_CHANNEL_VERSION_5, /* v5 channel */
- ConsoleCloseProc, /* Close proc. */
- ConsoleInputProc, /* Input proc. */
- ConsoleOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- NULL, /* Set option proc. */
- NULL, /* Get option proc. */
- ConsoleWatchProc, /* Set up notifier to watch the channel. */
- ConsoleGetHandleProc, /* Get an OS handle from channel. */
- ConsoleClose2Proc, /* close2proc. */
- ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
- NULL, /* Flush proc. */
- NULL, /* Handler proc. */
- NULL, /* Wide seek proc. */
- ConsoleThreadActionProc, /* Thread action proc. */
- NULL /* Truncation proc. */
+ "console", /* Type name. */
+ TCL_CHANNEL_VERSION_5, /* v5 channel */
+ TCL_CLOSE2PROC, /* Close proc. */
+ ConsoleInputProc, /* Input proc. */
+ ConsoleOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ ConsoleSetOptionProc, /* Set option proc. */
+ ConsoleGetOptionProc, /* Get option proc. */
+ ConsoleWatchProc, /* Set up notifier to watch the channel. */
+ ConsoleGetHandleProc, /* Get an OS handle from channel. */
+ ConsoleCloseProc, /* close2proc. */
+ ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
+ NULL, /* Flush proc. */
+ NULL, /* Handler proc. */
+ NULL, /* Wide seek proc. */
+ ConsoleThreadActionProc, /* Thread action proc. */
+ NULL /* Truncation proc. */
};
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * RingBufferInit --
+ *
+ * Initializes the ring buffer to a given size.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Panics on allocation failure.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+RingBufferInit(RingBuffer *ringPtr, Tcl_Size capacity)
+{
+ if (capacity <= 0 || capacity > TCL_SIZE_MAX) {
+ Tcl_Panic("Internal error: invalid ring buffer capacity requested.");
+ }
+ ringPtr->bufPtr = (char *)ckalloc(capacity);
+ ringPtr->capacity = capacity;
+ ringPtr->start = 0;
+ ringPtr->length = 0;
+}
/*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*
- * ReadConsoleBytes, WriteConsoleBytes --
+ * RingBufferClear
*
- * Wrapper for ReadConsoleW, that takes and returns number of bytes
- * instead of number of WCHARS.
+ * Clears the contents of a ring buffer.
*
- *----------------------------------------------------------------------
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The allocated internal buffer is freed.
+ *
+ *------------------------------------------------------------------------
*/
+static void
+RingBufferClear(RingBuffer *ringPtr)
+{
+ if (ringPtr->bufPtr) {
+ ckfree(ringPtr->bufPtr);
+ ringPtr->bufPtr = NULL;
+ }
+ ringPtr->capacity = 0;
+ ringPtr->start = 0;
+ ringPtr->length = 0;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * RingBufferIn --
+ *
+ * Appends data to the ring buffer.
+ *
+ * Results:
+ * Returns number of bytes copied.
+ *
+ * Side effects:
+ * Internal buffer is updated.
+ *
+ *------------------------------------------------------------------------
+ */
+static Tcl_Size
+RingBufferIn(
+ RingBuffer *ringPtr,
+ const char *srcPtr, /* Source to be copied */
+ Tcl_Size srcLen, /* Length of source */
+ int partialCopyOk /* If true, partial copy is permitted */
+ )
+{
+ Tcl_Size freeSpace;
+
+ RINGBUFFER_ASSERT(ringPtr);
+
+ freeSpace = ringPtr->capacity - ringPtr->length;
+ if (freeSpace < srcLen) {
+ if (!partialCopyOk) {
+ return 0;
+ }
+ /* Copy only as much as free space allows */
+ srcLen = freeSpace;
+ }
+
+ if (ringPtr->capacity - ringPtr->start > ringPtr->length) {
+ /* There is room at the back */
+ Tcl_Size endSpaceStart = ringPtr->start + ringPtr->length;
+ Tcl_Size endSpace = ringPtr->capacity - endSpaceStart;
+ if (endSpace >= srcLen) {
+ /* Everything fits at the back */
+ memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, srcLen);
+ } else {
+ /* srcLen > endSpace */
+ memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace);
+ memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace);
+ }
+ } else {
+ /* No room at the back. Existing data wrap to front. */
+ Tcl_Size wrapLen =
+ ringPtr->start + ringPtr->length - ringPtr->capacity;
+ memmove(wrapLen + ringPtr->bufPtr, srcPtr, srcLen);
+ }
+
+ ringPtr->length += srcLen;
+
+ RINGBUFFER_ASSERT(ringPtr);
+
+ return srcLen;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * RingBufferOut --
+ *
+ * Moves data out of the ring buffer. If dstPtr is NULL, the data
+ * is simply removed.
+ *
+ * Results:
+ * Returns number of bytes copied or removed.
+ *
+ * Side effects:
+ * Internal buffer is updated.
+ *
+ *------------------------------------------------------------------------
+ */
+static Tcl_Size
+RingBufferOut(RingBuffer *ringPtr,
+ char *dstPtr, /* Buffer for output data. May be NULL */
+ Tcl_Size dstCapacity, /* Size of buffer */
+ int partialCopyOk) /* If true, return what's available */
+{
+ Tcl_Size leadLen;
-static BOOL
-ReadConsoleBytes(
+ RINGBUFFER_ASSERT(ringPtr);
+
+ if (dstCapacity > ringPtr->length) {
+ if (dstPtr && !partialCopyOk) {
+ return 0;
+ }
+ dstCapacity = ringPtr->length;
+ }
+
+ if (ringPtr->start <= (ringPtr->capacity - ringPtr->length)) {
+ /* No content wrap around. So leadLen is entire content */
+ leadLen = ringPtr->length;
+ } else {
+ /* Content wraps around so lead segment stretches to end of buffer */
+ leadLen = ringPtr->capacity - ringPtr->start;
+ }
+ if (leadLen >= dstCapacity) {
+ if (dstPtr) {
+ memmove(dstPtr, ringPtr->start + ringPtr->bufPtr, dstCapacity);
+ }
+ ringPtr->start += dstCapacity;
+ } else {
+ Tcl_Size wrapLen = dstCapacity - leadLen;
+ if (dstPtr) {
+ memmove(dstPtr,
+ ringPtr->start + ringPtr->bufPtr,
+ leadLen);
+ memmove(
+ leadLen + dstPtr, ringPtr->bufPtr, wrapLen);
+ }
+ ringPtr->start = wrapLen;
+ }
+
+ ringPtr->length -= dstCapacity;
+ if (ringPtr->start == ringPtr->capacity || ringPtr->length == 0) {
+ ringPtr->start = 0;
+ }
+
+ RINGBUFFER_ASSERT(ringPtr);
+
+ return dstCapacity;
+}
+
+#ifndef NDEBUG
+static int
+RingBufferCheck(const RingBuffer *ringPtr)
+{
+ return (ringPtr->bufPtr != NULL && ringPtr->capacity == CONSOLE_BUFFER_SIZE
+ && ringPtr->start < ringPtr->capacity
+ && ringPtr->length <= ringPtr->capacity);
+}
+#endif
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ReadConsoleChars --
+ *
+ * Wrapper for ReadConsoleW.
+ *
+ * Results:
+ * Returns 0 on success, else Windows error code.
+ *
+ * Side effects:
+ * On success the number of characters (not bytes) read is stored in
+ * *nCharsReadPtr. This will be 0 if the operation was interrupted by
+ * a Ctrl-C or a CancelIo call.
+ *
+ *------------------------------------------------------------------------
+ */
+static DWORD
+ReadConsoleChars(
HANDLE hConsole,
- LPVOID lpBuffer,
- DWORD nbytes,
- LPDWORD nbytesread)
+ WCHAR *lpBuffer,
+ Tcl_Size nChars,
+ Tcl_Size *nCharsReadPtr)
{
- DWORD ntchars;
+ DWORD nRead;
BOOL result;
/*
- * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return
- * success with ntchars == 0 and GetLastError() will be
- * ERROR_OPERATION_ABORTED. We do not want to treat this case
- * as EOF so we will loop around again. If no Ctrl signal handlers
- * have been established, the default signal OS handler in a separate
- * thread will terminate the program. If a Ctrl signal handler
- * has been established (through an extension for example), it
- * will run and take whatever action it deems appropriate.
+ * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return success
+ * with ntchars == 0 and GetLastError() will be ERROR_OPERATION_ABORTED.
+ * If no Ctrl signal handlers have been established, the default signal
+ * OS handler in a separate thread will terminate the program. If a Ctrl
+ * signal handler has been established (through an extension for
+ * example), it will run and take whatever action it deems appropriate.
+ *
+ * If one thread closes its channel, it calls CancelSynchronousIo on the
+ * console handle which results again in success being returned and
+ * GetLastError() being ERROR_OPERATION_ABORTED but ntchars in
+ * unmodified.
+ *
+ * In both cases above we will return success but with nbytesread as 0.
+ * This allows caller to check for thread termination etc.
+ *
+ * See https://bugs.python.org/issue30237
+ * or https://github.com/microsoft/terminal/issues/12143
*/
- do {
- result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars,
- NULL);
- } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED);
- if (nbytesread != NULL) {
- *nbytesread = ntchars * sizeof(WCHAR);
- }
- return result;
+ nRead = (DWORD)-1;
+ result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL);
+ if (result) {
+ if ((nRead == 0 || nRead == (DWORD)-1)
+ && GetLastError() == ERROR_OPERATION_ABORTED) {
+ nRead = 0;
+ }
+ *nCharsReadPtr = nRead;
+ return 0;
+ } else
+ return GetLastError();
}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * WriteConsoleChars --
+ *
+ * Wrapper for WriteConsoleW.
+ *
+ * Results:
+ * Returns 0 on success, Windows error code on failure.
+ *
+ * Side effects:
+ * On success the number of characters (not bytes) written is stored in
+ * *nCharsWrittenPtr. This will be 0 if the operation was interrupted by
+ * a Ctrl-C or a CancelIo call.
+ *
+ *------------------------------------------------------------------------
+ */
-static BOOL
-WriteConsoleBytes(
+static DWORD
+WriteConsoleChars(
HANDLE hConsole,
- const void *lpBuffer,
- DWORD nbytes,
- LPDWORD nbyteswritten)
+ const WCHAR *lpBuffer,
+ Tcl_Size nChars,
+ Tcl_Size *nCharsWrittenPtr)
{
- DWORD ntchars;
+ DWORD nCharsWritten;
BOOL result;
- result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars,
- NULL);
- if (nbyteswritten != NULL) {
- *nbyteswritten = ntchars * sizeof(WCHAR);
+ /* See comments in ReadConsoleChars, not sure that applies here */
+ nCharsWritten = (DWORD)-1;
+ result = WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL);
+ if (result) {
+ if (nCharsWritten == (DWORD) -1) {
+ nCharsWritten = 0;
+ }
+ *nCharsWrittenPtr = nCharsWritten;
+ return 0;
+ } else {
+ return GetLastError();
}
- return result;
}
/*
@@ -273,19 +626,19 @@ ConsoleInit(void)
* is a speed enhancement.
*/
- if (!initialized) {
- Tcl_MutexLock(&consoleMutex);
- if (!initialized) {
- initialized = 1;
+ if (!gInitialized) {
+ AcquireSRWLockExclusive(&gConsoleLock);
+ if (!gInitialized) {
+ gInitialized = 1;
Tcl_CreateExitHandler(ProcExitHandler, NULL);
}
- Tcl_MutexUnlock(&consoleMutex);
+ ReleaseSRWLockExclusive(&gConsoleLock);
}
if (TclThreadDataKeyGet(&dataKey) == NULL) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- tsdPtr->firstConsolePtr = NULL;
+ tsdPtr->notUsed = 0;
Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
}
@@ -310,10 +663,8 @@ ConsoleInit(void)
static void
ConsoleExitHandler(
- ClientData clientData) /* Old window proc. */
+ TCL_UNUSED(ClientData))
{
- (void)clientData;
-
Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
}
@@ -336,13 +687,48 @@ ConsoleExitHandler(
static void
ProcExitHandler(
- ClientData clientData) /* Old window proc. */
+ TCL_UNUSED(ClientData))
{
- (void)clientData;
-
- Tcl_MutexLock(&consoleMutex);
- initialized = 0;
- Tcl_MutexUnlock(&consoleMutex);
+ AcquireSRWLockExclusive(&gConsoleLock);
+ gInitialized = 0;
+ ReleaseSRWLockExclusive(&gConsoleLock);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * NudgeWatchers --
+ *
+ * Wakes up all threads which have file event watchers on the passed
+ * console handle.
+ *
+ * The function locks and releases gConsoleLock.
+ * Caller must not be holding locks that will violate lock hierarchy.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * As above.
+ *------------------------------------------------------------------------
+ */
+void NudgeWatchers (HANDLE consoleHandle)
+{
+ ConsoleChannelInfo *chanInfoPtr;
+ AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */
+ for (chanInfoPtr = gWatchingChannelList; chanInfoPtr;
+ chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
+ /*
+ * Notify channels interested in our handle AND that have
+ * a thread attached.
+ * No lock needed for chanInfoPtr. See ConsoleChannelInfo.
+ */
+ if (chanInfoPtr->handle == consoleHandle
+ && chanInfoPtr->threadId != NULL) {
+ Tcl_ThreadAlert(chanInfoPtr->threadId);
+ }
+ }
+ ReleaseSRWLockShared(&gConsoleLock);
}
/*
@@ -351,7 +737,9 @@ ProcExitHandler(
* ConsoleSetupProc --
*
* This procedure is invoked before Tcl_DoOneEvent blocks waiting for an
- * event.
+ * event. It walks the channel list and if any input channel has data
+ * available or output channel has space for data, sets the event loop
+ * blocking time to 0 so that it will poll immediately.
*
* Results:
* None.
@@ -364,38 +752,48 @@ ProcExitHandler(
void
ConsoleSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
- ConsoleInfo *infoPtr;
+ ConsoleChannelInfo *chanInfoPtr;
Tcl_Time blockTime = { 0, 0 };
int block = 1;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)data;
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
/*
- * Look to see if any events are already pending. If they are, poll.
+ * Walk the list of channels. See general comments for struct
+ * ConsoleChannelInfo with regard to locking and field access.
*/
-
- for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->writer.readyEvent,
- 0) != WAIT_TIMEOUT) {
- block = 0;
- }
- }
- if (infoPtr->watchMask & TCL_READABLE) {
- if (WaitForRead(infoPtr, 0) >= 0) {
- block = 0;
+ AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */
+
+ for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL;
+ chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
+ ConsoleHandleInfo *handleInfoPtr;
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr != NULL) {
+ AcquireSRWLockShared(&handleInfoPtr->lock);
+ /* Remember at most one of READABLE, WRITABLE set */
+ if (chanInfoPtr->watchMask & TCL_READABLE) {
+ if (RingBufferLength(&handleInfoPtr->buffer) > 0
+ || handleInfoPtr->lastError != ERROR_SUCCESS) {
+ block = 0; /* Input data available */
+ }
+ } else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
+ if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
+ /* TCL_WRITABLE */
+ block = 0; /* Output space available */
+ }
}
+ ReleaseSRWLockShared(&handleInfoPtr->lock);
}
}
+ ReleaseSRWLockShared(&gConsoleLock);
+
if (!block) {
+ /* At least one channel is readable/writable. Set block time to 0 */
Tcl_SetMaxBlockTime(&blockTime);
}
}
@@ -419,57 +817,87 @@ ConsoleSetupProc(
static void
ConsoleCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
- ConsoleInfo *infoPtr;
+ ConsoleChannelInfo *chanInfoPtr;
+ Tcl_ThreadId me;
int needEvent;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
+ me = Tcl_GetCurrentThread();
+
/*
- * Queue events for any ready consoles that don't already have events
- * queued.
+ * Acquire a shared lock. Note this is ok even though we potentially
+ * modify the chanInfoPtr->flags because chanInfoPtr is only modified
+ * when it belongs to this thread and no other thread will write to it.
+ * THe shared lock is intended to protect the global gWatchingChannelList
+ * as we traverse it.
*/
+ AcquireSRWLockShared(&gConsoleLock);
- for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->flags & CONSOLE_PENDING) {
+ for (chanInfoPtr = gWatchingChannelList; chanInfoPtr != NULL;
+ chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
+ ConsoleHandleInfo *handleInfoPtr;
+
+ if (chanInfoPtr->threadId != me) {
+ /* Some other thread owns the channel */
+ continue;
+ }
+ if (chanInfoPtr->flags & CONSOLE_EVENT_QUEUED) {
+ /* A notification event already queued. No point in another. */
continue;
}
- /*
- * Queue an event if the console is signaled for reading or writing.
- */
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ /* Pointer is safe to access as we are holding gConsoleLock */
- needEvent = 0;
- if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->writer.readyEvent,
- 0) != WAIT_TIMEOUT) {
- needEvent = 1;
- }
+ if (handleInfoPtr == NULL) {
+ /* Stale event */
+ continue;
}
- if (infoPtr->watchMask & TCL_READABLE) {
- if (WaitForRead(infoPtr, 0) >= 0) {
- needEvent = 1;
+ needEvent = 0;
+ AcquireSRWLockShared(&handleInfoPtr->lock);
+ /* Rememeber channel is read or write, never both */
+ if (chanInfoPtr->watchMask & TCL_READABLE) {
+ if (RingBufferLength(&handleInfoPtr->buffer) > 0
+ || handleInfoPtr->lastError != ERROR_SUCCESS) {
+ needEvent = 1; /* Input data available or error/EOF */
+ }
+ /*
+ * TCL_READABLE watch means someone is looking out for data being
+ * available, let reader thread know. Note channel need not be
+ * ASYNC! (Bug [baa51423c2])
+ */
+ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
+ } else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
+ if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
+ needEvent = 1; /* Output space available */
}
}
+ ReleaseSRWLockShared(&handleInfoPtr->lock);
if (needEvent) {
ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent));
- infoPtr->flags |= CONSOLE_PENDING;
+ /* See note above loop why this can be accessed without locks */
+ chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED;
+ chanInfoPtr->numRefs += 1; /* So it does not go away while event
+ is in queue */
evPtr->header.proc = ConsoleEventProc;
- evPtr->infoPtr = infoPtr;
+ evPtr->chanInfoPtr = chanInfoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
+
+ ReleaseSRWLockShared(&gConsoleLock);
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -492,7 +920,7 @@ ConsoleBlockModeProc(
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
/*
* Consoles on Windows can not be switched between blocking and
@@ -503,9 +931,9 @@ ConsoleBlockModeProc(
*/
if (mode == TCL_MODE_NONBLOCKING) {
- infoPtr->flags |= CONSOLE_ASYNC;
+ chanInfoPtr->flags |= CONSOLE_ASYNC;
} else {
- infoPtr->flags &= ~CONSOLE_ASYNC;
+ chanInfoPtr->flags &= ~CONSOLE_ASYNC;
}
return 0;
}
@@ -513,7 +941,7 @@ ConsoleBlockModeProc(
/*
*----------------------------------------------------------------------
*
- * ConsoleCloseProc/ConsoleClose2Proc --
+ * ConsoleCloseProc --
*
* Closes a console based IO channel.
*
@@ -528,101 +956,105 @@ ConsoleBlockModeProc(
static int
ConsoleCloseProc(
- ClientData instanceData, /* Pointer to ConsoleInfo structure. */
- Tcl_Interp *interp) /* For error reporting. */
+ ClientData instanceData, /* Pointer to ConsoleChannelInfo structure. */
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
{
- ConsoleInfo *consolePtr = (ConsoleInfo *)instanceData;
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+ ConsoleHandleInfo *handleInfoPtr;
int errorCode = 0;
- ConsoleInfo *infoPtr, **nextPtrPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ConsoleChannelInfo **nextPtrPtr;
+ int closeHandle;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
/*
- * Clean up the background thread if necessary. Note that this must be
- * done before we can close the file, since the thread may be blocking
- * trying to read from the console.
+ * Don't close the Win32 handle if the handle is a standard channel
+ * during the thread exit process. Otherwise, one thread may kill the
+ * stdio of another while exiting. Note an explicit close in script will
+ * still close the handle. That's historical behavior on all platforms.
*/
+ if (!TclInThreadExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) {
+ closeHandle = 1;
+ } else {
+ closeHandle = 0;
+ }
+
+ AcquireSRWLockExclusive(&gConsoleLock);
- if (consolePtr->reader.thread) {
- TclPipeThreadStop(&consolePtr->reader.TI, consolePtr->reader.thread);
- CloseHandle(consolePtr->reader.thread);
- CloseHandle(consolePtr->reader.readyEvent);
- consolePtr->reader.thread = NULL;
+ /* Remove channel from watchers' list */
+ for (nextPtrPtr = &gWatchingChannelList; *nextPtrPtr != NULL;
+ nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) {
+ if (*nextPtrPtr == (ConsoleChannelInfo *) chanInfoPtr) {
+ *nextPtrPtr = (*nextPtrPtr)->nextWatchingChannelPtr;
+ break;
+ }
}
- consolePtr->validMask &= ~TCL_READABLE;
- /*
- * Wait for the writer thread to finish the current buffer, then terminate
- * the thread and close the handles. If the channel is nonblocking, there
- * should be no pending write operations.
- */
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr) {
+ /*
+ * Console thread may be blocked either waiting for console i/o
+ * or waiting on the condition variable for buffer empty/full
+ */
+ AcquireSRWLockShared(&handleInfoPtr->lock);
- if (consolePtr->writer.thread) {
- if (consolePtr->toWrite) {
+ if (closeHandle) {
+ handleInfoPtr->console = INVALID_HANDLE_VALUE;
+ }
+
+ /* Break the thread out of blocking console i/o */
+ handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */
+ if (handleInfoPtr->numRefs == 1) {
/*
- * We only need to wait if there is something to write. This may
- * prevent infinite wait on exit. [Python Bug 216289]
+ * Abort the i/o if no other threads are listening on it.
+ * Note without this check, an input line will be skipped on
+ * the cancel.
*/
-
- WaitForSingleObject(consolePtr->writer.readyEvent, 5000);
+ CancelSynchronousIo(handleInfoPtr->consoleThread);
}
- TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread);
- CloseHandle(consolePtr->writer.thread);
- CloseHandle(consolePtr->writer.readyEvent);
- consolePtr->writer.thread = NULL;
+ /*
+ * Wake up the console handling thread. Note we do not explicitly
+ * tell it handle is closed (below). It will find out on next access
+ */
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
+
+ ReleaseSRWLockShared(&handleInfoPtr->lock);
}
- consolePtr->validMask &= ~TCL_WRITABLE;
- /*
- * Don't close the Win32 handle if the handle is a standard channel during
- * the thread exit process. Otherwise, one thread may kill the stdio of
- * another.
- */
+ ReleaseSRWLockExclusive(&gConsoleLock);
- if (!TclInThreadExit()
- || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle)
- && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle)
- && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) {
- if (CloseHandle(consolePtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
+ chanInfoPtr->channel = NULL;
+ chanInfoPtr->watchMask = 0;
+ chanInfoPtr->permissions = 0;
+
+ if (closeHandle && chanInfoPtr->handle != INVALID_HANDLE_VALUE) {
+ if (CloseHandle(chanInfoPtr->handle) == FALSE) {
+ Tcl_WinConvertError(GetLastError());
errorCode = errno;
}
+ chanInfoPtr->handle = INVALID_HANDLE_VALUE;
}
- consolePtr->watchMask &= consolePtr->validMask;
-
/*
- * Remove the file from the list of watched files.
+ * Note, we can check and manipulate numRefs without a lock because
+ * we have removed it from the watch queue so the console thread cannot
+ * get at it.
*/
-
- for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr;
- infoPtr != NULL;
- nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
- if (infoPtr == (ConsoleInfo *) consolePtr) {
- *nextPtrPtr = infoPtr->nextPtr;
- break;
- }
- }
- if (consolePtr->writeBuf != NULL) {
- ckfree(consolePtr->writeBuf);
- consolePtr->writeBuf = 0;
+ if (chanInfoPtr->numRefs > 1) {
+ /* There may be references already on the event queue */
+ chanInfoPtr->numRefs -= 1;
+ } else {
+ ckfree(chanInfoPtr);
}
- ckfree(consolePtr);
return errorCode;
}
-
-static int
-ConsoleClose2Proc(
- ClientData instanceData, /* Pointer to ConsoleInfo structure. */
- Tcl_Interp *interp, /* For error reporting. */
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return ConsoleCloseProc(instanceData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -641,80 +1073,140 @@ ConsoleClose2Proc(
*
*----------------------------------------------------------------------
*/
-
static int
ConsoleInputProc(
ClientData instanceData, /* Console state. */
- char *buf, /* Where to store data read. */
+ char *bufPtr, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
- DWORD count, bytesRead = 0;
- int result;
-
- *errorCode = 0;
-
- /*
- * Synchronize with the reader thread.
- */
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+ ConsoleHandleInfo *handleInfoPtr;
+ Tcl_Size numRead;
- result = WaitForRead(infoPtr, (infoPtr->flags & CONSOLE_ASYNC) ? 0 : 1);
+ if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
+ return 0; /* EOF */
+ }
- /*
- * If an error occurred, return immediately.
- */
+ *errorCode = 0;
- if (result == -1) {
- *errorCode = errno;
- return -1;
+ AcquireSRWLockShared(&gConsoleLock);
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr == NULL) {
+ /* Really shouldn't happen since channel is holding a reference */
+ ReleaseSRWLockShared(&gConsoleLock);
+ return 0; /* EOF */
}
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */
- if (infoPtr->readFlags & CONSOLE_BUFFERED) {
+ while (1) {
+ numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1);
/*
- * Data is stored in the buffer.
+ * Note: even if channel is closed or has an error, as long there is
+ * buffered data, we will pass it up.
*/
+ if (numRead != 0) {
+ break;
+ }
+ /*
+ * No data available.
+ * - If an error was recorded, generate that and reset it.
+ * - If EOF, indicate as much. It is up to the application to close
+ * the channel.
+ * - Otherwise, if non-blocking return EAGAIN or wait for more data.
+ */
+ if (handleInfoPtr->lastError != 0) {
+ if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) {
+ numRead = 0; /* Treat as EOF */
+ } else {
+ Tcl_WinConvertError(handleInfoPtr->lastError);
+ handleInfoPtr->lastError = 0;
+ *errorCode = Tcl_GetErrno();
+ numRead = -1;
+ }
+ break;
+ }
+ if (handleInfoPtr->console == INVALID_HANDLE_VALUE) {
+ /* EOF - break with numRead == 0 */
+ chanInfoPtr->handle = INVALID_HANDLE_VALUE;
+ break;
+ }
- if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
- bytesRead = bufSize;
- infoPtr->offset += bufSize;
- } else {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
- bytesRead = infoPtr->bytesRead - infoPtr->offset;
-
- /*
- * Reset the buffer.
- */
+ /* For async, tell caller we are blocked */
+ if (chanInfoPtr->flags & CONSOLE_ASYNC) {
+ *errorCode = EWOULDBLOCK;
+ numRead = -1;
+ break;
+ }
- infoPtr->readFlags &= ~CONSOLE_BUFFERED;
- infoPtr->offset = 0;
+ /*
+ * Blocking read. Just get data from directly from console. There
+ * is a small complication in that we can only read even number
+ * of bytes (wide-character API) and the destination buffer should be
+ * WCHAR aligned. If either condition is not met, we defer to the
+ * reader thread which handles these case rather than dealing with
+ * them here (which is a little trickier than it might sound.)
+ */
+ if ((1 & (ptrdiff_t)bufPtr) == 0 /* aligned buffer */
+ && bufSize > 1 /* Not single byte read */
+ ) {
+ DWORD lastError;
+ Tcl_Size numChars;
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ lastError = ReadConsoleChars(chanInfoPtr->handle,
+ (WCHAR *)bufPtr,
+ bufSize / sizeof(WCHAR),
+ &numChars);
+ /* NOTE lock released so DON'T break. Return instead */
+ if (lastError != ERROR_SUCCESS) {
+ Tcl_WinConvertError(lastError);
+ *errorCode = Tcl_GetErrno();
+ return -1;
+ } else if (numChars > 0) {
+ /* Successfully read something. */
+ return numChars * sizeof(WCHAR);
+ } else {
+ /*
+ * Ctrl-C/Ctrl-Brk interrupt. Loop around to retry.
+ * We have to reacquire the lock. No worried about handleInfoPtr
+ * having gone away since the channel holds a reference.
+ */
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ continue;
+ }
+ }
+ /*
+ * Deferring blocking read to reader thread.
+ * Release the lock and sleep. Note that because the channel
+ * holds a reference count on handleInfoPtr, it will not
+ * be deallocated while the lock is released.
+ */
+ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
+ if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV,
+ &handleInfoPtr->lock,
+ INFINITE,
+ 0)) {
+ Tcl_WinConvertError(GetLastError());
+ *errorCode = Tcl_GetErrno();
+ numRead = -1;
+ break;
}
- return bytesRead;
+ /* Lock is reacquired, loop back to try again */
}
- /*
- * Attempt to read bufSize bytes. The read will return immediately if
- * there is any data available. Otherwise it will block until at least one
- * byte is available or an EOF occurs.
- */
-
- if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize,
- &count) == TRUE) {
- /*
- * TODO: This potentially writes beyond the limits specified
- * by the caller. In practice this is harmless, since all writes
- * are into ChannelBuffers, and those have padding, but still
- * ought to remove this, unless some Windows wizard can give
- * a reason not to.
- */
- buf[count] = '\0';
- return count;
+ /* We read data. Ask for more if either async or watching for reads */
+ if ((chanInfoPtr->flags & CONSOLE_ASYNC)
+ || (chanInfoPtr->watchMask & TCL_READABLE)) {
+ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
}
- return -1;
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ return numRead;
}
/*
@@ -734,7 +1226,6 @@ ConsoleInputProc(
*
*----------------------------------------------------------------------
*/
-
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
@@ -742,74 +1233,112 @@ ConsoleOutputProc(
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
- ConsoleThreadInfo *threadInfo = &infoPtr->writer;
- DWORD bytesWritten, timeout;
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+ ConsoleHandleInfo *handleInfoPtr;
+ Tcl_Size numWritten;
*errorCode = 0;
- /* avoid blocking if pipe-thread exited */
- timeout = (infoPtr->flags & CONSOLE_ASYNC) || !TclPipeThreadIsAlive(&threadInfo->TI)
- || TclInExit() || TclInThreadExit() ? 0 : INFINITE;
- if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) {
- /*
- * The writer thread is blocked waiting for a write to complete and
- * the channel is in non-blocking mode.
- */
-
- errno = EWOULDBLOCK;
- goto error;
+ if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
+ /* Some other thread would have *previously* closed the stdio handle */
+ *errorCode = EPIPE;
+ return -1;
}
- /*
- * Check for a background error on the last write.
- */
-
- if (infoPtr->writeError) {
- TclWinConvertError(infoPtr->writeError);
- infoPtr->writeError = 0;
- goto error;
+ AcquireSRWLockShared(&gConsoleLock);
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr == NULL) {
+ /* Really shouldn't happen since channel is holding a reference */
+ *errorCode = EPIPE;
+ ReleaseSRWLockShared(&gConsoleLock);
+ return -1;
}
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */
+
+ /* Keep looping until all written. Break out for async and errors */
+ numWritten = 0;
+ while (1) {
+ /* Check for error and closing on every loop. */
+ if (handleInfoPtr->lastError != 0) {
+ Tcl_WinConvertError(handleInfoPtr->lastError);
+ *errorCode = Tcl_GetErrno();
+ numWritten = -1;
+ break;
+ }
+ if (handleInfoPtr->console == INVALID_HANDLE_VALUE) {
+ *errorCode = EPIPE;
+ chanInfoPtr->handle = INVALID_HANDLE_VALUE;
+ numWritten = -1;
+ break;
+ }
- if (infoPtr->flags & CONSOLE_ASYNC) {
/*
- * The console is non-blocking, so copy the data into the output
- * buffer and restart the writer thread.
+ * We can either write directly or through the console thread's
+ * ring buffer. We have to do the latter when
+ * (1) the operation is async since WriteConsoleChars is always blocking
+ * (2) when there is already data in the ring buffer because we don't
+ * want to reorder output from within a thread
+ * (3) when there are an odd number of bytes since WriteConsole
+ * takes whole WCHARs
+ * (4) when the pointer is not aligned on WCHAR
+ * The ring buffer deals with cases (3) and (4). It would be harder
+ * to duplicate that here.
*/
-
- if (toWrite > infoPtr->writeBufLen) {
+ if ((chanInfoPtr->flags & CONSOLE_ASYNC) /* Case (1) */
+ || RingBufferLength(&handleInfoPtr->buffer) != 0 /* Case (2) */
+ || (toWrite & 1) != 0 /* Case (3) */
+ || (PTR2INT(buf) & 1) != 0 /* Case (4) */
+ ) {
+ numWritten += RingBufferIn(&handleInfoPtr->buffer,
+ numWritten + buf,
+ toWrite - numWritten,
+ 1);
+ if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) {
+ /* All done or async, just accept whatever was written */
+ break;
+ }
/*
- * Reallocate the buffer to be large enough to hold the data.
+ * Release the lock and sleep. Note that because the channel
+ * holds a reference count on handleInfoPtr, it will not
+ * be deallocated while the lock is released.
*/
-
- if (infoPtr->writeBuf) {
- ckfree(infoPtr->writeBuf);
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
+ if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV,
+ &handleInfoPtr->lock,
+ INFINITE,
+ 0)) {
+ /* Report the error */
+ Tcl_WinConvertError(GetLastError());
+ *errorCode = Tcl_GetErrno();
+ numWritten = -1;
+ break;
+ }
+ } else {
+ /* Direct output */
+ DWORD winStatus;
+ HANDLE consoleHandle = handleInfoPtr->console;
+ /* Unlock before blocking in WriteConsole */
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ /* UNLOCKED so return, DON'T break out of loop as it will unlock again! */
+ winStatus = WriteConsoleChars(consoleHandle,
+ (WCHAR *)buf,
+ toWrite / sizeof(WCHAR),
+ &numWritten);
+ if (winStatus == ERROR_SUCCESS) {
+ return numWritten * sizeof(WCHAR);
+ } else {
+ Tcl_WinConvertError(winStatus);
+ *errorCode = Tcl_GetErrno();
+ return -1;
}
- infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
- memcpy(infoPtr->writeBuf, buf, toWrite);
- infoPtr->toWrite = toWrite;
- ResetEvent(threadInfo->readyEvent);
- TclPipeThreadSignal(&threadInfo->TI);
- bytesWritten = toWrite;
- } else {
- /*
- * In the blocking case, just try to write the buffer directly. This
- * avoids an unnecessary copy.
- */
- if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite,
- &bytesWritten) == FALSE) {
- TclWinConvertError(GetLastError());
- goto error;
- }
+ /* Lock must have been reacquired before continuing loop */
}
- return bytesWritten;
-
- error:
- *errorCode = errno;
- return -1;
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ return numWritten;
}
/*
@@ -840,66 +1369,84 @@ ConsoleEventProc(
* such as TCL_FILE_EVENTS. */
{
ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
- ConsoleInfo *infoPtr;
- int mask;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ConsoleChannelInfo *chanInfoPtr;
+ int freeChannel;
+ int mask = 0;
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
+ chanInfoPtr = consoleEvPtr->chanInfoPtr;
/*
- * Search through the list of watched consoles for the one whose handle
- * matches the event. We do this rather than simply dereferencing the
- * handle in the event so that consoles can be deleted while the event is
- * in the queue.
+ * We know chanInfoPtr is valid because its reference count would have
+ * been incremented when the event was queued. The corresponding release
+ * happens in this function.
*/
- for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (consoleEvPtr->infoPtr == infoPtr) {
- infoPtr->flags &= ~CONSOLE_PENDING;
- break;
- }
- }
-
/*
- * Remove stale events.
+ * Global lock used for chanInfoPtr. A read (shared) lock suffices
+ * because all access is within the channel owning thread with the
+ * exception of watchers which is a read-only access. See comments
+ * to ConsoleChannelInfo.
*/
-
- if (!infoPtr) {
- return 1;
- }
+ AcquireSRWLockShared(&gConsoleLock);
+ chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED;
/*
- * Check to see if the console is readable. Note that we can't tell if a
- * console is writable, so we always report it as being writable unless we
- * have detected EOF.
+ * Only handle the event if the Tcl channel has not gone away AND is
+ * still owned by this thread AND is still watching events.
*/
-
- mask = 0;
- if (infoPtr->watchMask & TCL_WRITABLE) {
- if (WaitForSingleObject(infoPtr->writer.readyEvent,
- 0) != WAIT_TIMEOUT) {
- mask = TCL_WRITABLE;
- }
- }
-
- if (infoPtr->watchMask & TCL_READABLE) {
- if (WaitForRead(infoPtr, 0) >= 0) {
- if (infoPtr->readFlags & CONSOLE_EOF) {
+ if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread()
+ && (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) {
+ ConsoleHandleInfo *handleInfoPtr;
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr == NULL) {
+ /* Console was closed. EOF->read event only (not write) */
+ if (chanInfoPtr->watchMask & TCL_READABLE) {
mask = TCL_READABLE;
- } else {
- mask |= TCL_READABLE;
}
+ } else {
+ AcquireSRWLockShared(&handleInfoPtr->lock);
+ /* Remember at most one of READABLE, WRITABLE set */
+ if ((chanInfoPtr->watchMask & TCL_READABLE)
+ && RingBufferLength(&handleInfoPtr->buffer)) {
+ mask = TCL_READABLE;
+ } else if ((chanInfoPtr->watchMask & TCL_WRITABLE)
+ && RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
+ /* Generate write event space available */
+ mask = TCL_WRITABLE;
+ }
+ ReleaseSRWLockShared(&handleInfoPtr->lock);
}
}
/*
- * Inform the channel of the events.
+ * Tcl_NotifyChannel can recurse through the file event callback so need
+ * to release locks first. Our reference still holds so no danger of
+ * chanInfoPtr being deallocated if the callback closes the channel.
*/
+ ReleaseSRWLockShared(&gConsoleLock);
+ if (mask) {
+ Tcl_NotifyChannel(chanInfoPtr->channel, mask);
+ /* Note: chanInfoPtr ref count may have changed */
+ }
+
+ /* No need to lock - see comments earlier */
+
+ /* Remove the reference to the channel from event record */
+ if (chanInfoPtr->numRefs > 1) {
+ chanInfoPtr->numRefs -= 1;
+ freeChannel = 0;
+ } else {
+ assert(chanInfoPtr->channel == NULL);
+ freeChannel = 1;
+ }
+
+ if (freeChannel) {
+ ckfree(chanInfoPtr);
+ }
- Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
return 1;
}
@@ -922,42 +1469,58 @@ ConsoleEventProc(
static void
ConsoleWatchProc(
ClientData instanceData, /* Console state. */
- int mask) /* What events to watch for, OR-ed combination
- * of TCL_READABLE, TCL_WRITABLE and
- * TCL_EXCEPTION. */
+ int newMask) /* What events to watch for, one of
+ * of TCL_READABLE, TCL_WRITABLE
+ */
{
- ConsoleInfo **nextPtrPtr, *ptr;
- ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
- int oldMask = infoPtr->watchMask;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ConsoleChannelInfo **nextPtrPtr, *ptr;
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+ int oldMask = chanInfoPtr->watchMask;
/*
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
- infoPtr->watchMask = mask & infoPtr->validMask;
- if (infoPtr->watchMask) {
+ chanInfoPtr->watchMask = newMask & chanInfoPtr->permissions;
+ if (chanInfoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
- infoPtr->nextPtr = tsdPtr->firstConsolePtr;
- tsdPtr->firstConsolePtr = infoPtr;
+ AcquireSRWLockExclusive(&gConsoleLock);
+ /* Add to list of watched channels */
+ chanInfoPtr->nextWatchingChannelPtr = gWatchingChannelList;
+ gWatchingChannelList = chanInfoPtr;
+
+ /*
+ * For read channels, need to tell the console reader thread
+ * that we are looking for data since it will not do reads until
+ * it knows someone is awaiting.
+ */
+ ConsoleHandleInfo *handleInfoPtr;
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr) {
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
+ WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ }
+ ReleaseSRWLockExclusive(&gConsoleLock);
}
Tcl_SetMaxBlockTime(&blockTime);
} else if (oldMask) {
- /*
- * Remove the console from the list of watched consoles.
- */
+ /* Remove from list of watched channels */
- for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr;
+ AcquireSRWLockExclusive(&gConsoleLock);
+ for (nextPtrPtr = &gWatchingChannelList, ptr = *nextPtrPtr;
ptr != NULL;
- nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
- if (infoPtr == ptr) {
- *nextPtrPtr = ptr->nextPtr;
+ nextPtrPtr = &ptr->nextWatchingChannelPtr, ptr = *nextPtrPtr) {
+ if (chanInfoPtr == ptr) {
+ *nextPtrPtr = ptr->nextWatchingChannelPtr;
break;
}
}
+ ReleaseSRWLockExclusive(&gConsoleLock);
}
}
@@ -982,120 +1545,68 @@ ConsoleWatchProc(
static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
- int direction, /* TCL_READABLE or TCL_WRITABLE. */
+ TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
- ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
- (void)direction;
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
- *handlePtr = infoPtr->handle;
- return TCL_OK;
+ if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) {
+ return TCL_ERROR;
+ } else {
+ *handlePtr = chanInfoPtr->handle;
+ return TCL_OK;
+ }
}
/*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*
- * WaitForRead --
+ * ConsoleDataAvailable --
*
- * Wait until some data is available, the console is at EOF or the reader
- * thread is blocked waiting for data (if the channel is in non-blocking
- * mode).
+ * Checks if there is data in the console input queue.
*
* Results:
- * Returns 1 if console is readable. Returns 0 if there is no data on the
- * console, but there is buffered data. Returns -1 if an error occurred.
- * If an error occurred, the threads may not be synchronized.
+ * Returns 1 if the input queue has data, -1 on error else 0 if empty.
*
* Side effects:
- * Updates the shared state flags. If no error occurred, the reader
- * thread is blocked waiting for a signal from the main thread.
+ * None.
*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*/
-
-static int
-WaitForRead(
- ConsoleInfo *infoPtr, /* Console state. */
- int blocking) /* Indicates whether call should be blocking
- * or not. */
+ static int
+ ConsoleDataAvailable (HANDLE consoleHandle)
{
- DWORD timeout, count;
- HANDLE *handle = (HANDLE *)infoPtr->handle;
- ConsoleThreadInfo *threadInfo = &infoPtr->reader;
- INPUT_RECORD input;
-
- while (1) {
- /*
- * Synchronize with the reader thread.
- */
-
- /* avoid blocking if pipe-thread exited */
- timeout = (!blocking || !TclPipeThreadIsAlive(&threadInfo->TI)
- || TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
- if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) {
- /*
- * The reader thread is blocked waiting for data and the channel
- * is in non-blocking mode.
- */
-
- errno = EWOULDBLOCK;
- return -1;
- }
-
- /*
- * At this point, the two threads are synchronized, so it is safe to
- * access shared state.
- */
-
- /*
- * If the console has hit EOF, it is always readable.
- */
-
- if (infoPtr->readFlags & CONSOLE_EOF) {
- return 1;
- }
-
- if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) {
- /*
- * Check to see if the peek failed because of EOF.
- */
-
- TclWinConvertError(GetLastError());
-
- if (errno == EOF) {
- infoPtr->readFlags |= CONSOLE_EOF;
- return 1;
- }
-
- /*
- * Ignore errors if there is data in the buffer.
- */
-
- if (infoPtr->readFlags & CONSOLE_BUFFERED) {
- return 0;
- } else {
- return -1;
- }
- }
-
- /*
- * If there is data in the buffer, the console must be readable (since
- * it is a line-oriented device).
- */
+ INPUT_RECORD input[10];
+ DWORD count;
+ DWORD i;
- if (infoPtr->readFlags & CONSOLE_BUFFERED) {
+ /*
+ * Need at least one keyboard event.
+ */
+ if (PeekConsoleInputW(
+ consoleHandle, input, sizeof(input) / sizeof(input[0]), &count)
+ == FALSE) {
+ return -1;
+ }
+ /*
+ * Even if windows size and mouse events are disabled, can still have
+ * events other than keyboard, like focus events. Look for at least one
+ * keydown event because a trailing LF keyup is always present from the
+ * last input. However, if our buffer is full, assume there is a key
+ * down somewhere in the unread buffer. I suppose we could expand the
+ * buffer but not worth...
+ */
+ if (count == (sizeof(input)/sizeof(input[0])))
+ return 1;
+ for (i = 0; i < count; ++i) {
+ if (input[i].EventType == KEY_EVENT
+ && input[i].Event.KeyEvent.bKeyDown) {
return 1;
}
-
- /*
- * There wasn't any data available, so reset the thread and try again.
- */
-
- ResetEvent(threadInfo->readyEvent);
- TclPipeThreadSignal(&threadInfo->TI);
}
+ return 0;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1105,12 +1616,10 @@ WaitForRead(
* available on a console.
*
* Results:
- * None.
+ * Always 0.
*
* Side effects:
- * Signals the main thread when input become available. May cause the
- * main thread to wake up by posting a message. May one line from the
- * console for each wait operation.
+ * Signals the main thread when input become available.
*
*----------------------------------------------------------------------
*/
@@ -1119,76 +1628,178 @@ static DWORD WINAPI
ConsoleReaderThread(
LPVOID arg)
{
- TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
- ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */
- HANDLE handle = NULL;
- ConsoleThreadInfo *threadInfo = NULL;
- int done = 0;
+ ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
+ ConsoleHandleInfo **iterator;
+ char inputChars[200]; /* Temporary buffer */
+ Tcl_Size inputLen = 0;
+ Tcl_Size inputOffset = 0;
- while (!done) {
- /*
- * Wait for the main thread to signal before attempting to read.
- */
+ /*
+ * Keep looping until one of the following happens.
+ * - there are no more channels listening on the console
+ * - the console handle has been closed
+ */
+
+ /* This thread is holding a reference so pointer is safe */
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+
+ while (1) {
- if (!TclPipeThreadWaitForSignal(&pipeTI)) {
- /* exit */
+ if (handleInfoPtr->numRefs == 1) {
+ /*
+ * Sole reference. That's this thread. Exit since no clients
+ * and no way for a thread to attach to a console after process
+ * start.
+ */
break;
}
- if (!infoPtr) {
- infoPtr = (ConsoleInfo *)pipeTI->clientData;
- handle = infoPtr->handle;
- threadInfo = &infoPtr->reader;
- }
-
/*
- * Look for data on the console, but first ignore any events that are
- * not KEY_EVENTs.
+ * Shared buffer has no data. If we have some in our private buffer
+ * copy that. Else check if there has been an error. In both cases
+ * notify the interp threads.
*/
+ if (inputLen > 0 || handleInfoPtr->lastError != 0) {
+ HANDLE consoleHandle;
+ if (inputLen > 0) {
+ /* Private buffer has data. Copy it over. */
+ Tcl_Size nStored;
+
+ assert((inputLen - inputOffset) > 0);
+
+ nStored = RingBufferIn(&handleInfoPtr->buffer,
+ inputOffset + inputChars,
+ inputLen - inputOffset,
+ 1);
+ inputOffset += nStored;
+ if (inputOffset == inputLen) {
+ /* Temp buffer now empty */
+ inputOffset = 0;
+ inputLen = 0;
+ }
+ } else {
+ /*
+ * On error, nothing but inform caller and wait
+ * We do not want to exit until there are no client interps.
+ */
+ }
- if (ReadConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
- (LPDWORD) &infoPtr->bytesRead) != FALSE) {
/*
- * Data was stored in the buffer.
+ * Wake up any threads waiting either synchronously or
+ * asynchronously. Since we are providing data, turn off the
+ * AWAITED flag. If the data provided is not sufficient the
+ * clients will request again. Note we have to wake up ALL
+ * awaiting threads, not just one, so they can all reissue
+ * requests if needed. (In a properly designed app, at most one
+ * thread should be reading standard input but...)
*/
+ handleInfoPtr->flags &= ~CONSOLE_DATA_AWAITED;
+ /* Wake synchronous channels */
+ WakeAllConditionVariable(&handleInfoPtr->interpThreadCV);
+ /*
+ * Wake up async channels registered for file events. Note in
+ * order to follow the locking hierarchy, we need to release
+ * handleInfoPtr->lock before calling NudgeWatchers.
+ */
+ consoleHandle = handleInfoPtr->console;
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ NudgeWatchers(consoleHandle);
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
- infoPtr->readFlags |= CONSOLE_BUFFERED;
- } else {
- DWORD err = GetLastError();
-
- if (err == (DWORD) EOF) {
- infoPtr->readFlags = CONSOLE_EOF;
- }
- done = 1;
+ /*
+ * Loop back to recheck for exit conditions changes while the
+ * the lock was not held.
+ */
+ continue;
}
/*
- * Signal the main thread by signalling the readable event and then
- * waking up the notifier thread.
- */
-
- SetEvent(threadInfo->readyEvent);
-
- /*
- * Alert the foreground thread. Note that we need to treat this like a
- * critical section so the foreground thread does not terminate this
- * thread while we are holding a mutex in the notifier code.
+ * Both shared buffer and private buffer are empty. Need to go get
+ * data from console but do not want to read ahead because the
+ * interp thread might change the read mode, e.g. turning off echo
+ * for password input. So only do so if at least one interpreter has
+ * requested data.
*/
-
- Tcl_MutexLock(&consoleMutex);
- if (infoPtr->threadId != NULL) {
+ if ((handleInfoPtr->flags & CONSOLE_DATA_AWAITED)
+ && ConsoleDataAvailable(handleInfoPtr->console)) {
+ DWORD error;
+ /* Do not hold the lock while blocked in console */
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ /*
+ * Note - the temporary buffer serves two purposes. It
+ */
+ error = ReadConsoleChars(handleInfoPtr->console,
+ (WCHAR *)inputChars,
+ sizeof(inputChars) / sizeof(WCHAR),
+ &inputLen);
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ if (error == 0) {
+ inputLen *= sizeof(WCHAR);
+ } else {
+ /*
+ * We only store the last error. It is up to channel
+ * handlers whether to close or not in case of errors.
+ */
+ handleInfoPtr->lastError = error;
+ if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) {
+ handleInfoPtr->console = INVALID_HANDLE_VALUE;
+ }
+ }
+ } else {
/*
- * TIP #218. When in flight ignore the event, no one will receive
- * it anyway.
+ * Either no one was asking for data, or no data was available.
+ * In the former case, wait until someone wakes us asking for
+ * data. In the latter case, there is no alternative but to
+ * poll since ReadConsole does not support async operation.
+ * So sleep for a short while and loop back to retry.
*/
+ DWORD sleepTime;
+ sleepTime =
+ handleInfoPtr->flags & CONSOLE_DATA_AWAITED ? 50 : INFINITE;
+ SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV,
+ &handleInfoPtr->lock,
+ sleepTime,
+ 0);
+ }
+
+ /* Loop again to check for exit or wait for readers to wake us */
+ }
- Tcl_ThreadAlert(infoPtr->threadId);
+ /*
+ * Exiting:
+ * - remove the console from global list
+ * - close the handle if still valid
+ * - release the structure
+ * Note there is not need to check for any watchers because we only
+ * exit when there are no channels open to this console.
+ */
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
+ for (iterator = &gConsoleHandleInfoList; *iterator;
+ iterator = &(*iterator)->nextPtr) {
+ if (*iterator == handleInfoPtr) {
+ *iterator = handleInfoPtr->nextPtr;
+ break;
}
- Tcl_MutexUnlock(&consoleMutex);
}
+ ReleaseSRWLockExclusive(&gConsoleLock);
- /* Worker exit, so inform the main thread or free TI-structure (if owned) */
- TclPipeThreadExit(&pipeTI);
+ /* No need for relocking - no other thread should have access to it now */
+ RingBufferClear(&handleInfoPtr->buffer);
+
+ if (handleInfoPtr->console != INVALID_HANDLE_VALUE
+ && handleInfoPtr->lastError != ERROR_INVALID_HANDLE) {
+ SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode);
+ /*
+ * NOTE: we do not call CloseHandle(handleInfoPtr->console) here.
+ * As per the GetStdHandle documentation, it need not be closed.
+ * Other components may be directly using it. Note however that
+ * an explicit chan close script command does close the handle
+ * for all threads.
+ */
+ }
+
+ ckfree(handleInfoPtr);
return 0;
}
@@ -1205,89 +1816,258 @@ ConsoleReaderThread(
* Always returns 0.
*
* Side effects:
-
- * Signals the main thread when an output operation is completed. May
- * cause the main thread to wake up by posting a message.
+ * Signals the main thread when an output operation is completed.
*
*----------------------------------------------------------------------
*/
-
static DWORD WINAPI
-ConsoleWriterThread(
- LPVOID arg)
+ConsoleWriterThread(LPVOID arg)
{
- TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
- ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */
- HANDLE handle = NULL;
- ConsoleThreadInfo *threadInfo = NULL;
- DWORD count, toWrite;
- char *buf;
- int done = 0;
-
- while (!done) {
- /*
- * Wait for the main thread to signal before attempting to write.
- */
- if (!TclPipeThreadWaitForSignal(&pipeTI)) {
- /* exit */
- break;
- }
- if (!infoPtr) {
- infoPtr = (ConsoleInfo *)pipeTI->clientData;
- handle = infoPtr->handle;
- threadInfo = &infoPtr->writer;
- }
+ ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg;
+ ConsoleHandleInfo **iterator;
+ BOOL success;
+ Tcl_Size numBytes;
+ /*
+ * This buffer size has no relation really with the size of the shared
+ * buffer. Could be bigger or smaller. Make larger as multiple threads
+ * could potentially be writing to it.
+ */
+ char buffer[2*CONSOLE_BUFFER_SIZE];
+
+ /*
+ * Keep looping until one of the following happens.
+ *
+ * - there are not more channels listening on the console
+ * - the console handle has been closed
+ *
+ * On each iteration,
+ * - if the channel buffer is empty, wait for some channel writer to write
+ * - if there is data in our buffer, write it to the console
+ */
- buf = infoPtr->writeBuf;
- toWrite = infoPtr->toWrite;
+ /* This thread is holding a reference so pointer is safe */
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ while (1) {
+ /* handleInfoPtr->lock must be held on entry to loop */
+
+ int offset;
+ HANDLE consoleHandle;
/*
- * Loop until all of the bytes are written or an error occurs.
+ * Sadly, we need to do another copy because do not want to hold
+ * a lock on handleInfoPtr->buffer while calling WriteConsole as that
+ * might block. Also, we only want to copy an integral number of
+ * WCHAR's, i.e. even number of chars so do some length checks up
+ * front.
*/
-
- while (toWrite > 0) {
- if (WriteConsoleBytes(handle, buf, (DWORD) toWrite,
- &count) == FALSE) {
- infoPtr->writeError = GetLastError();
- done = 1;
+ numBytes = RingBufferLength(&handleInfoPtr->buffer);
+ numBytes &= ~1; /* Copy integral number of WCHARs -> even number of bytes */
+ if (numBytes == 0) {
+ /* No data to write */
+ if (handleInfoPtr->numRefs == 1) {
+ /*
+ * Sole reference. That's this thread. Exit since no clients
+ * and no buffered output.
+ */
break;
}
- toWrite -= count;
- buf += count;
+ /* Wake up any threads waiting synchronously. */
+ WakeConditionVariable(&handleInfoPtr->interpThreadCV);
+ success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV,
+ &handleInfoPtr->lock,
+ INFINITE,
+ 0);
+ /* Note: lock has been acquired again! */
+ if (!success && GetLastError() != ERROR_TIMEOUT) {
+ /* TODO - what can be done? Should not happen */
+ /* For now keep going */
+ }
+ continue;
}
- /*
- * Signal the main thread by signalling the writable event and then
- * waking up the notifier thread.
- */
-
- SetEvent(threadInfo->readyEvent);
+ /* We have data to write */
+ if ((size_t)numBytes > (sizeof(buffer) / sizeof(buffer[0]))) {
+ numBytes = sizeof(buffer);
+ }
+ /* No need to check result, we already checked length bytes available */
+ RingBufferOut(&handleInfoPtr->buffer, buffer, numBytes, 0);
+
+ consoleHandle = handleInfoPtr->console;
+ WakeConditionVariable(&handleInfoPtr->interpThreadCV);
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ offset = 0;
+ while (numBytes > 0) {
+ Tcl_Size numWChars = numBytes / sizeof(WCHAR);
+ DWORD status;
+ status = WriteConsoleChars(handleInfoPtr->console,
+ (WCHAR *)(offset + buffer),
+ numWChars,
+ &numWChars);
+ if (status != 0) {
+ /* Only overwrite if no previous error */
+ if (handleInfoPtr->lastError == 0) {
+ handleInfoPtr->lastError = status;
+ }
+ if (status == ERROR_INVALID_HANDLE) {
+ handleInfoPtr->console = INVALID_HANDLE_VALUE;
+ }
+ /* Assume this write is done but keep looping in case
+ * it is a transient error. Not sure just closing handle
+ * and exiting thread is a good idea until all references
+ * from interp threads are gone.
+ */
+ break;
+ }
+ numBytes -= numWChars * sizeof(WCHAR);
+ offset += numWChars * sizeof(WCHAR);
+ }
+ /* Wake up any threads waiting synchronously. */
+ WakeConditionVariable(&handleInfoPtr->interpThreadCV);
/*
- * Alert the foreground thread. Note that we need to treat this like a
- * critical section so the foreground thread does not terminate this
- * thread while we are holding a mutex in the notifier code.
+ * Wake up all channels registered for file events. Note in
+ * order to follow the locking hierarchy, we cannot hold any locks
+ * when calling NudgeWatchers.
*/
+ NudgeWatchers(consoleHandle);
- Tcl_MutexLock(&consoleMutex);
- if (infoPtr->threadId != NULL) {
- /*
- * TIP #218. When in flight ignore the event, no one will receive
- * it anyway.
- */
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ }
- Tcl_ThreadAlert(infoPtr->threadId);
+ /*
+ * Exiting:
+ * - remove the console from global list
+ * - release the structure
+ * NOTE: we do not call CloseHandle(handleInfoPtr->console) here.
+ * As per the GetStdHandle documentation, it need not be closed.
+ * Other components may be directly using it. Note however that
+ * an explicit chan close script command does close the handle
+ * for all threads.
+ */
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+ AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */
+ for (iterator = &gConsoleHandleInfoList; *iterator;
+ iterator = &(*iterator)->nextPtr) {
+ if (*iterator == handleInfoPtr) {
+ *iterator = handleInfoPtr->nextPtr;
+ break;
}
- Tcl_MutexUnlock(&consoleMutex);
}
+ ReleaseSRWLockExclusive(&gConsoleLock);
- /* Worker exit, so inform the main thread or free TI-structure (if owned) */
- TclPipeThreadExit(&pipeTI);
+ RingBufferClear(&handleInfoPtr->buffer);
+
+ ckfree(handleInfoPtr);
return 0;
}
/*
+ *------------------------------------------------------------------------
+ *
+ * AllocateConsoleHandleInfo --
+ *
+ * Allocates a ConsoleHandleInfo for the passed console handle. As
+ * a side effect starts a console thread to handle i/o on the handle.
+ *
+ * Important: Caller must be holding an EXCLUSIVE lock on gConsoleLock
+ * when calling this function. The lock continues to be held on return.
+ *
+ * Results:
+ * Pointer to an unlocked ConsoleHandleInfo structure. The reference
+ * count on the structure is 1. This corresponds to the common reference
+ * from the console thread and the gConsoleHandleInfoList. Returns NULL
+ * on error.
+ *
+ * Side effects:
+ * A console reader or writer thread is started. The returned structure
+ * is placed on the active console handler list gConsoleHandleInfoList.
+ *
+ *------------------------------------------------------------------------
+ */
+static ConsoleHandleInfo *
+AllocateConsoleHandleInfo(
+ HANDLE consoleHandle,
+ int permissions) /* TCL_READABLE or TCL_WRITABLE */
+{
+ ConsoleHandleInfo *handleInfoPtr;
+ DWORD consoleMode;
+
+
+ handleInfoPtr = (ConsoleHandleInfo *)ckalloc(sizeof(*handleInfoPtr));
+ memset(handleInfoPtr, 0, sizeof(*handleInfoPtr));
+ handleInfoPtr->console = consoleHandle;
+ InitializeSRWLock(&handleInfoPtr->lock);
+ InitializeConditionVariable(&handleInfoPtr->consoleThreadCV);
+ InitializeConditionVariable(&handleInfoPtr->interpThreadCV);
+ RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE);
+ handleInfoPtr->lastError = 0;
+ handleInfoPtr->permissions = permissions;
+ handleInfoPtr->numRefs = 1; /* See function header */
+ if (permissions == TCL_READABLE) {
+ GetConsoleMode(consoleHandle, &handleInfoPtr->initMode);
+ consoleMode = handleInfoPtr->initMode;
+ consoleMode &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
+ consoleMode |= ENABLE_LINE_INPUT;
+ SetConsoleMode(consoleHandle, consoleMode);
+ }
+ handleInfoPtr->consoleThread = CreateThread(
+ NULL, /* default security descriptor */
+ 2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */
+ permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread,
+ handleInfoPtr, /* Pass to thread */
+ 0, /* Flags - no special cases */
+ NULL); /* Don't care about thread id */
+ if (handleInfoPtr->consoleThread == NULL) {
+ /* Note - SRWLock and condition variables do not need finalization */
+ RingBufferClear(&handleInfoPtr->buffer);
+ ckfree(handleInfoPtr);
+ return NULL;
+ }
+
+ /* Chain onto global list */
+ handleInfoPtr->nextPtr = gConsoleHandleInfoList;
+ gConsoleHandleInfoList = handleInfoPtr;
+
+ return handleInfoPtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * FindConsoleInfo --
+ *
+ * Finds the ConsoleHandleInfo record for a given ConsoleChannelInfo.
+ * The found record must match the console handle. It is the caller's
+ * responsibility to check the permissions (read/write) in the returned
+ * ConsoleHandleInfo match permissions in chanInfoPtr. This function does
+ * not check that.
+ *
+ * Important: Caller must be holding an shared or exclusive lock on
+ * gConsoleMutex. That ensures the returned pointer stays valid on
+ * return without risk of deallocation by other threads.
+ *
+ * Results:
+ * Pointer to the found ConsoleHandleInfo or NULL if not found
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+static ConsoleHandleInfo *
+FindConsoleInfo(const ConsoleChannelInfo *chanInfoPtr)
+{
+ ConsoleHandleInfo *handleInfoPtr;
+ for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) {
+ if (handleInfoPtr->console == chanInfoPtr->handle) {
+ return handleInfoPtr;
+ }
+ }
+ return NULL;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclWinOpenConsoleChannel --
@@ -1304,30 +2084,30 @@ ConsoleWriterThread(
*
*----------------------------------------------------------------------
*/
-
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
- ConsoleInfo *infoPtr;
- DWORD modes;
+ ConsoleChannelInfo *chanInfoPtr;
+ ConsoleHandleInfo *handleInfoPtr;
- ConsoleInit();
+ /* A console handle can either be input or output, not both */
+ if (permissions != TCL_READABLE && permissions != TCL_WRITABLE) {
+ return NULL;
+ }
- /*
- * See if a channel with this handle already exists.
- */
+ ConsoleInit();
- infoPtr = (ConsoleInfo *)ckalloc(sizeof(ConsoleInfo));
- memset(infoPtr, 0, sizeof(ConsoleInfo));
+ chanInfoPtr = (ConsoleChannelInfo *)ckalloc(sizeof(*chanInfoPtr));
+ memset(chanInfoPtr, 0, sizeof(*chanInfoPtr));
- infoPtr->validMask = permissions;
- infoPtr->handle = handle;
- infoPtr->channel = (Tcl_Channel) NULL;
+ chanInfoPtr->permissions = permissions;
+ chanInfoPtr->handle = handle;
+ chanInfoPtr->channel = (Tcl_Channel) NULL;
- infoPtr->threadId = Tcl_GetCurrentThread();
+ chanInfoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
@@ -1335,10 +2115,7 @@ TclWinOpenConsoleChannel(
* for instance).
*/
- snprintf(channelName, TCL_INTEGER_SPACE + 4, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
-
- infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
- infoPtr, permissions);
+ snprintf(channelName, 16 + TCL_INTEGER_SPACE, "file%" TCL_Z_MODIFIER "x", (size_t) chanInfoPtr);
if (permissions & TCL_READABLE) {
/*
@@ -1347,36 +2124,76 @@ TclWinOpenConsoleChannel(
* we only want to catch when complete lines are ready for reading.
*/
- GetConsoleMode(infoPtr->handle, &modes);
- modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
- modes |= ENABLE_LINE_INPUT;
- SetConsoleMode(infoPtr->handle, modes);
+ chanInfoPtr->flags |= CONSOLE_READ_OPS;
+ GetConsoleMode(handle, &chanInfoPtr->initMode);
- infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL);
- infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread,
- TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr,
- infoPtr->reader.readyEvent), 0, NULL);
+#ifdef OBSOLETE
+ /* Why was priority being set on console input? Code smell */
SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST);
+#endif
+ } else {
+ /* Already checked permissions is WRITABLE if not READABLE */
+ /* TODO - enable ansi escape processing? */
}
- if (permissions & TCL_WRITABLE) {
+ /*
+ * Global lock but that's ok. See comments top of file. Allocations
+ * will happen only a few times in the life of a process and that too
+ * generally at start up where only one thread is active.
+ */
+ AcquireSRWLockExclusive(&gConsoleLock); /*Allocate needs exclusive lock */
- infoPtr->writer.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL);
- infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread,
- TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr,
- infoPtr->writer.readyEvent), 0, NULL);
- SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST);
+ handleInfoPtr = FindConsoleInfo(chanInfoPtr);
+ if (handleInfoPtr == NULL) {
+ /* Not found. Allocate one */
+ handleInfoPtr = AllocateConsoleHandleInfo(handle, permissions);
+ } else {
+ /* Found. Its direction (read/write) better be the same */
+ if (handleInfoPtr->permissions != permissions) {
+ handleInfoPtr = NULL;
+ }
}
+ if (handleInfoPtr == NULL) {
+ ReleaseSRWLockExclusive(&gConsoleLock);
+ if (permissions == TCL_READABLE) {
+ SetConsoleMode(handle, chanInfoPtr->initMode);
+ }
+ ckfree(chanInfoPtr);
+ return NULL;
+ }
+
+ /*
+ * There is effectively a reference to this structure from the Tcl
+ * channel subsystem. So record that. This reference will be dropped
+ * when the Tcl channel is closed.
+ */
+ chanInfoPtr->numRefs = 1;
+
+ /*
+ * Need to keep track of number of referencing channels for closing.
+ * The pointer is safe since there is a reference held to it from
+ * gConsoleHandleInfoList but still need to lock the structure itself
+ */
+ AcquireSRWLockExclusive(&handleInfoPtr->lock);
+ handleInfoPtr->numRefs += 1;
+ ReleaseSRWLockExclusive(&handleInfoPtr->lock);
+
+ ReleaseSRWLockExclusive(&gConsoleLock);
+
+ /* Note Tcl_CreateChannel never fails other than panic on error */
+ chanInfoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
+ chanInfoPtr, permissions);
+
/*
- * Files have default translation of AUTO and ^Z eof char, which means
+ * Consoles have default translation of auto and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
- return infoPtr->channel;
+ Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-eofchar", "\x1A {}");
+ Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-encoding", "utf-16");
+ return chanInfoPtr->channel;
}
/*
@@ -1400,33 +2217,222 @@ ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
- ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+
+ /* No need for any locks as no other thread will be writing to it */
+ if (action == TCL_CHANNEL_THREAD_INSERT) {
+ ConsoleInit(); /* Needed to set up event source handlers for this thread */
+ chanInfoPtr->threadId = Tcl_GetCurrentThread();
+ } else {
+ chanInfoPtr->threadId = NULL;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleSetOptionProc --
+ *
+ * Sets an option on a channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets the interp's result on error if
+ * interp is not NULL.
+ *
+ * Side effects:
+ * May modify an option on a console. Sets Error message if needed (by
+ * calling Tcl_BadChannelOption).
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ConsoleSetOptionProc(
+ ClientData instanceData, /* File state. */
+ Tcl_Interp *interp, /* For error reporting - can be NULL. */
+ const char *optionName, /* Which option to set? */
+ const char *value) /* New value for option. */
+{
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+ int len = strlen(optionName);
+ int vlen = strlen(value);
/*
- * We do not access firstConsolePtr in the thread structures. This is not
- * for all serials managed by the thread, but only those we are watching.
- * Removal of the fileevent handlers before transfer thus takes care of
- * this structure.
+ * Option -inputmode normal|password|raw
*/
- Tcl_MutexLock(&consoleMutex);
- if (action == TCL_CHANNEL_THREAD_INSERT) {
+ if ((chanInfoPtr->flags & CONSOLE_READ_OPS) && (len > 1) &&
+ (strncmp(optionName, "-inputmode", len) == 0)) {
+ DWORD mode;
+
+ if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) {
+ Tcl_WinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read console mode: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) {
+ mode |=
+ ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT;
+ } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
+ mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT;
+ mode &= ~ENABLE_ECHO_INPUT;
+ } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
+ mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT);
+ } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
+ /*
+ * Reset to the initial mode, whatever that is.
+ */
+ mode = chanInfoPtr->initMode;
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad mode \"%s\" for -inputmode: must be"
+ " normal, password, raw, or reset", value));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+ "VALUE", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (SetConsoleMode(chanInfoPtr->handle, mode) == 0) {
+ Tcl_WinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set console mode: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+ }
+
+ if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
+ return Tcl_BadChannelOption(interp, optionName, "inputmode");
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleGetOptionProc --
+ *
+ * Gets a mode associated with an IO channel. If the optionName arg is
+ * non-NULL, retrieves the value of that option. If the optionName arg is
+ * NULL, retrieves a list of alternating option names and values for the
+ * given channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets the supplied DString to the string
+ * value of the option(s) returned. Sets error message if needed
+ * (by calling Tcl_BadChannelOption).
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleGetOptionProc(
+ ClientData instanceData, /* File state. */
+ Tcl_Interp *interp, /* For error reporting - can be NULL. */
+ const char *optionName, /* Option to get. */
+ Tcl_DString *dsPtr) /* Where to store value(s). */
+{
+ ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
+ int valid = 0; /* Flag if valid option parsed. */
+ unsigned int len;
+ char buf[TCL_INTEGER_SPACE];
+
+ if (optionName == NULL) {
+ len = 0;
+ } else {
+ len = strlen(optionName);
+ }
+
+ /*
+ * Get option -inputmode
+ *
+ * This is a great simplification of the underlying reality, but actually
+ * represents what almost all scripts really want to know.
+ */
+
+ if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-inputmode");
+ }
+ if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
+ DWORD mode;
+
+ valid = 1;
+ if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) {
+ Tcl_WinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read console mode: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ if (mode & ENABLE_LINE_INPUT) {
+ if (mode & ENABLE_ECHO_INPUT) {
+ Tcl_DStringAppendElement(dsPtr, "normal");
+ } else {
+ Tcl_DStringAppendElement(dsPtr, "password");
+ }
+ } else {
+ Tcl_DStringAppendElement(dsPtr, "raw");
+ }
+ }
+ } else {
/*
- * We can't copy the thread information from the channel when the
- * channel is created. At this time the channel back pointer has not
- * been set yet. However in that case the threadId has already been
- * set by TclpCreateCommandChannel itself, so the structure is still
- * good.
+ * Output channel. Get option -winsize
+ * Option is readonly and returned by [fconfigure chan -winsize] but not
+ * returned by [fconfigure chan] without explicit option name.
*/
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-winsize");
+ }
- ConsoleInit();
- if (infoPtr->channel != NULL) {
- infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel);
+ if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) {
+ CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
+
+ valid = 1;
+ if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle,
+ &consoleInfo)) {
+ Tcl_WinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("couldn't read console size: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ Tcl_DStringStartSublist(dsPtr);
+ snprintf(buf, sizeof(buf),
+ "%d",
+ consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ snprintf(buf, sizeof(buf),
+ "%d",
+ consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ Tcl_DStringEndSublist(dsPtr);
}
+ }
+
+
+ if (valid) {
+ return TCL_OK;
+ }
+ if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
+ return Tcl_BadChannelOption(interp, optionName, "inputmode");
} else {
- infoPtr->threadId = NULL;
+ return Tcl_BadChannelOption(interp, optionName, "winsize");
}
- Tcl_MutexUnlock(&consoleMutex);
}
/*
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index deeb9d4..697aae6 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -79,7 +79,7 @@ static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.4.4"
+#define TCL_DDE_VERSION "1.4.5"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME L"TclEval"
#define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT"
@@ -117,7 +117,7 @@ static int DdeObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
+#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)
@@ -125,32 +125,20 @@ static int DdeObjCmd(void *clientData,
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
+#define Tcl_Size int
+#define TCL_INDEX_NONE -1
#endif
-static unsigned char *
-getByteArrayFromObj(
- Tcl_Obj *objPtr,
- size_t *lengthPtr
-) {
- int length;
-
- unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
-#if TCL_MAJOR_VERSION > 8
- if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
- /* 64-bit and TIP #494 situation: */
- *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
- } else
-#endif
- /* 32-bit or without TIP #494 */
- *lengthPtr = (size_t) (unsigned) length;
- return result;
-}
-
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Dde_Init(Tcl_Interp *interp);
DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
+#if TCL_MAJOR_VERSION < 9
+/* With those additional entries, "load dde14.dll" works without 3th argument */
+DLLEXPORT int Tcldde_Init(Tcl_Interp *interp);
+DLLEXPORT int Tcldde_SafeInit(Tcl_Interp *interp);
+#endif
#ifdef __cplusplus
}
#endif
@@ -183,6 +171,14 @@ Dde_Init(
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
}
+#if TCL_MAJOR_VERSION < 9
+int
+Tcldde_Init(
+ Tcl_Interp *interp)
+{
+ return Dde_Init(interp);
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -210,6 +206,14 @@ Dde_SafeInit(
}
return result;
}
+#if TCL_MAJOR_VERSION < 9
+int
+Tcldde_SafeInit(
+ Tcl_Interp *interp)
+{
+ return Dde_SafeInit(interp);
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -314,7 +318,8 @@ DdeSetServerName(
Tcl_DString dString;
const WCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
- int n, srvCount = 0, lastSuffix, r = TCL_OK;
+ Tcl_Size n, srvCount = 0;
+ int lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
@@ -410,7 +415,7 @@ DdeSetServerName(
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
Tcl_DStringInit(&ds);
- Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds);
+ Tcl_UtfToWCharDString(Tcl_GetString(namePtr), TCL_INDEX_NONE, &ds);
if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) {
suffix++;
Tcl_DStringFree(&ds);
@@ -568,7 +573,7 @@ ExecuteRemoteObject(
if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
"a handler procedure must be defined for use in a safe "
- "interp", -1));
+ "interp", TCL_INDEX_NONE));
Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
result = TCL_ERROR;
}
@@ -647,7 +652,7 @@ DdeServerProc(
/* Transaction-dependent data. */
{
Tcl_DString dString;
- size_t len;
+ Tcl_Size len;
DWORD dlen;
WCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
@@ -767,8 +772,7 @@ DdeServerProc(
CP_WINUNICODE);
if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
returnString =
- Tcl_GetString(convPtr->returnPackagePtr);
- len = convPtr->returnPackagePtr->length;
+ Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(returnString, len, &dsBuf);
@@ -790,8 +794,7 @@ DdeServerProc(
convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
- returnString = Tcl_GetString(variableObjPtr);
- len = variableObjPtr->length;
+ returnString = Tcl_GetStringFromObj(variableObjPtr, &len);
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(returnString, len, &dsBuf);
@@ -852,7 +855,7 @@ DdeServerProc(
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2);
utilString = (WCHAR *) Tcl_DStringValue(&ds2);
}
- variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
+ variableObjPtr = Tcl_NewStringObj((char *)utilString, TCL_INDEX_NONE);
Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
variableObjPtr, TCL_GLOBAL_ONLY);
@@ -1147,12 +1150,12 @@ DdeServicesOnAck(
GlobalGetAtomNameW(service, sz, 255);
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
- Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), TCL_INDEX_NONE));
Tcl_DStringFree(&dString);
GlobalGetAtomNameW(topic, sz, 255);
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
- Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
+ Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), TCL_INDEX_NONE));
Tcl_DStringFree(&dString);
/*
@@ -1270,7 +1273,7 @@ SetDdeError(
errorCode = "FAILED";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL);
}
@@ -1325,7 +1328,7 @@ DdeObjCmd(
};
int index, i, argIndex;
- size_t length;
+ Tcl_Size length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
@@ -1488,9 +1491,8 @@ DdeObjCmd(
Initialize();
if (firstArg != 1) {
- const char *src = Tcl_GetString(objv[firstArg]);
+ const char *src = Tcl_GetStringFromObj(objv[firstArg], &length);
- length = objv[firstArg]->length;
Tcl_DStringInit(&serviceBuf);
Tcl_UtfToWCharDString(src, length, &serviceBuf);
serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf);
@@ -1507,9 +1509,8 @@ DdeObjCmd(
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
- const char *src = Tcl_GetString(objv[firstArg + 1]);
+ const char *src = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
- length = objv[firstArg + 1]->length;
Tcl_DStringInit(&topicBuf);
topicName = Tcl_UtfToWCharDString(src, length, &topicBuf);
length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR);
@@ -1539,19 +1540,18 @@ DdeObjCmd(
break;
case DDE_EXECUTE: {
- size_t dataLength;
+ Tcl_Size dataLength;
const void *dataString;
Tcl_DString dsBuf;
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString =
- getByteArrayFromObj(objv[firstArg + 2], &dataLength);
+ Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
const char *src;
- src = Tcl_GetString(objv[firstArg + 2]);
- dataLength = objv[firstArg + 2]->length;
+ src = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
Tcl_DStringInit(&dsBuf);
dataString =
Tcl_UtfToWCharDString(src, dataLength, &dsBuf);
@@ -1560,7 +1560,7 @@ DdeObjCmd(
if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("cannot execute null data", -1));
+ Tcl_NewStringObj("cannot execute null data", TCL_INDEX_NONE));
Tcl_DStringFree(&dsBuf);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
@@ -1604,15 +1604,14 @@ DdeObjCmd(
const WCHAR *itemString;
const char *src;
- src = Tcl_GetString(objv[firstArg + 2]);
- length = objv[firstArg + 2]->length;
+ src = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
Tcl_DStringInit(&itemBuf);
itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("cannot request value of null data", -1));
+ Tcl_NewStringObj("cannot request value of null data", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
@@ -1672,14 +1671,13 @@ DdeObjCmd(
BYTE *dataString;
const char *src;
- src = Tcl_GetString(objv[firstArg + 2]);
- length = objv[firstArg + 2]->length;
+ src = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
Tcl_DStringInit(&itemBuf);
itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("cannot have a null item", -1));
+ Tcl_NewStringObj("cannot have a null item", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
@@ -1687,11 +1685,10 @@ DdeObjCmd(
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
- getByteArrayFromObj(objv[firstArg + 3], &length);
+ Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
} else {
const char *data =
- Tcl_GetString(objv[firstArg + 3]);
- length = objv[firstArg + 3]->length;
+ Tcl_GetStringFromObj(objv[firstArg + 3], &length);
Tcl_DStringInit(&dsBuf);
dataString = (BYTE *)
Tcl_UtfToWCharDString(data, length, &dsBuf);
@@ -1734,7 +1731,7 @@ DdeObjCmd(
if (serviceName == NULL) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("invalid service name \"\"", -1));
+ Tcl_NewStringObj("invalid service name \"\"", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
result = TCL_ERROR;
goto cleanup;
@@ -1782,7 +1779,7 @@ DdeObjCmd(
if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
"permission denied: a handler procedure must be"
- " defined for use in a safe interp", -1));
+ " defined for use in a safe interp", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
NULL);
result = TCL_ERROR;
@@ -1848,15 +1845,14 @@ DdeObjCmd(
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
invalidServerResponse:
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("invalid data returned from server", -1));
+ Tcl_NewStringObj("invalid data returned from server", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
- string = Tcl_GetString(objPtr);
- length = objPtr->length;
+ string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(string, length, &dsBuf);
string = Tcl_DStringValue(&dsBuf);
@@ -1906,7 +1902,7 @@ DdeObjCmd(
length = DdeGetData(ddeData, NULL, 0, 0);
ddeDataString = (WCHAR *) Tcl_Alloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
- if (length > sizeof(WCHAR)) {
+ if (length > (Tcl_Size)sizeof(WCHAR)) {
length -= sizeof(WCHAR);
}
Tcl_DStringInit(&dsBuf);
diff --git a/win/tclWinError.c b/win/tclWinError.c
index fea4b0f..7e5898b 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -4,7 +4,7 @@
* This file contains code for converting from Win32 errors to errno
* errors.
*
- * Copyright (c) 1995-1996 by 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.
@@ -334,7 +334,7 @@ static const unsigned char wsaErrorTable[] = {
/*
*----------------------------------------------------------------------
*
- * TclWinConvertError --
+ * Tcl_WinConvertError --
*
* This routine converts a Win32 error into an errno value.
*
@@ -348,8 +348,8 @@ static const unsigned char wsaErrorTable[] = {
*/
void
-TclWinConvertError(
- DWORD errCode) /* Win32 error code. */
+Tcl_WinConvertError(
+ unsigned errCode) /* Win32 error code. */
{
if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
errCode -= WSAEWOULDBLOCK;
@@ -391,21 +391,24 @@ tclWinDebugPanic(
if (IsDebuggerPresent()) {
WCHAR msgString[TCL_MAX_WARN_LEN];
- char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX];
+ char buf[TCL_MAX_WARN_LEN * 3];
vsnprintf(buf, sizeof(buf), format, argList);
- msgString[TCL_MAX_WARN_LEN-1] = L'\0';
+ msgString[TCL_MAX_WARN_LEN-1] = '\0';
MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
/*
* Truncate MessageBox string if it is too long to not overflow the buffer.
*/
- if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
+ if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
OutputDebugStringW(msgString);
} else {
+ if (!isatty(fileno(stderr))) {
+ fprintf(stderr, "\xEF\xBB\xBF");
+ }
vfprintf(stderr, format, argList);
fprintf(stderr, "\n");
fflush(stderr);
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 13d9ed8..acf61b7 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -4,7 +4,7 @@
* This file implements the Windows specific 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.
@@ -145,8 +145,8 @@ TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
- return DoRenameFile((WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
- (WCHAR *)Tcl_FSGetNativePath(destPathPtr));
+ return DoRenameFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
+ (const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
@@ -163,7 +163,7 @@ DoRenameFile(
int retval = -1;
/*
- * The MoveFileW API acts differently under Win95/98 and NT WRT NULL and
+ * The MoveFile API acts differently under Win95/98 and NT WRT NULL and
* "". Avoid passing these values.
*/
@@ -174,7 +174,7 @@ DoRenameFile(
}
/*
- * The MoveFileW API would throw an exception under NT if one of the
+ * The MoveFile API would throw an exception under NT if one of the
* arguments is a char block device.
*/
@@ -195,7 +195,7 @@ DoRenameFile(
/*
* Construct an TCLEXCEPTION_REGISTRATION to protect the call to
- * MoveFileW.
+ * MoveFile.
*/
"leal %[registration], %%edx" "\n\t"
@@ -224,7 +224,7 @@ DoRenameFile(
/*
* Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and
- * put the status return from MoveFileW into it.
+ * put the status return from MoveFile into it.
*/
"movl %%fs:0, %%edx" "\n\t"
@@ -279,7 +279,7 @@ DoRenameFile(
return retval;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
@@ -328,8 +328,10 @@ DoRenameFile(
CharLowerW(nativeSrcPath);
CharLowerW(nativeDstPath);
- src = Tcl_WinTCharToUtf((TCHAR *)nativeSrcPath, -1, &srcString);
- dst = Tcl_WinTCharToUtf((TCHAR *)nativeDstPath, -1, &dstString);
+ Tcl_DStringInit(&srcString);
+ Tcl_DStringInit(&dstString);
+ src = Tcl_WCharToUtfDString(nativeSrcPath, TCL_INDEX_NONE, &srcString);
+ dst = Tcl_WCharToUtfDString(nativeDstPath, TCL_INDEX_NONE, &dstString);
/*
* Check whether the destination path is actually inside the
@@ -369,7 +371,7 @@ DoRenameFile(
* errno should be EXDEV. It is very important to get this
* behavior, so that the caller can respond to a cross
* filesystem rename by simulating it with copy and delete.
- * The MoveFileW system call already handles the case of moving
+ * The MoveFile system call already handles the case of moving
* a file between filesystems.
*/
@@ -418,7 +420,7 @@ DoRenameFile(
* be, but report this one.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
CreateDirectoryW(nativeDst, NULL);
SetFileAttributesW(nativeDst, dstAttr);
if (Tcl_GetErrno() == EACCES) {
@@ -455,15 +457,15 @@ DoRenameFile(
return TCL_ERROR;
}
nativeTmp = (WCHAR *) tempBuf;
- nativeRest[0] = L'\0';
+ nativeRest[0] = '\0';
result = TCL_ERROR;
- nativePrefix = (WCHAR *) L"tclr";
+ nativePrefix = (WCHAR *)L"tclr";
if (GetTempFileNameW(nativeTmp, nativePrefix,
0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
- * MoveFileW to be joined as an atomic operation so no
+ * MoveFile to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
*/
@@ -486,7 +488,7 @@ DoRenameFile(
* error. Could happen if an open file refers to dst.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
@@ -534,8 +536,8 @@ TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
- return DoCopyFile((WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
- (WCHAR *)Tcl_FSGetNativePath(destPathPtr));
+ return DoCopyFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
+ (const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
@@ -667,7 +669,7 @@ DoCopyFile(
return retval;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
Tcl_SetErrno(EACCES);
return TCL_ERROR;
@@ -704,7 +706,7 @@ DoCopyFile(
* attributes of dst.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
SetFileAttributesW(nativeDst, dstAttr);
}
}
@@ -764,7 +766,7 @@ TclpDeleteFile(
if (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(path);
@@ -795,7 +797,7 @@ TclpDeleteFile(
(DeleteFileW(path) != FALSE)) {
return TCL_OK;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (res != 0) {
SetFileAttributesW(path, attr);
}
@@ -854,7 +856,7 @@ int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
- return DoCreateDirectory((WCHAR *)Tcl_FSGetNativePath(pathPtr));
+ return DoCreateDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr));
}
static int
@@ -864,7 +866,7 @@ DoCreateDirectory(
if (CreateDirectoryW(nativePath, NULL) == 0) {
DWORD error = GetLastError();
- TclWinConvertError(error);
+ Tcl_WinConvertError(error);
return TCL_ERROR;
}
return TCL_OK;
@@ -911,8 +913,10 @@ TclpObjCopyDirectory(
return TCL_ERROR;
}
- Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString);
- Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString);
+ Tcl_DStringInit(&srcString);
+ Tcl_DStringInit(&dstString);
+ Tcl_UtfToWCharDString(TclGetString(normSrcPtr), TCL_INDEX_NONE, &srcString);
+ Tcl_UtfToWCharDString(TclGetString(normDestPtr), TCL_INDEX_NONE, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
@@ -925,7 +929,7 @@ TclpObjCopyDirectory(
} else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
- *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE);
}
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
@@ -984,11 +988,12 @@ TclpObjRemoveDirectory(
if (normPtr == NULL) {
return TCL_ERROR;
}
- Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
+ Tcl_DStringInit(&native);
+ Tcl_UtfToWCharDString(TclGetString(normPtr), TCL_INDEX_NONE, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
- ret = DoRemoveJustDirectory((WCHAR *)Tcl_FSGetNativePath(pathPtr), 0, &ds);
+ ret = DoRemoveJustDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
if (ret != TCL_OK) {
@@ -997,7 +1002,7 @@ TclpObjRemoveDirectory(
!strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
*errorPtr = pathPtr;
} else {
- *errorPtr = TclDStringToObj(&ds);
+ *errorPtr = Tcl_DStringToObj(&ds);
}
Tcl_IncrRefCount(*errorPtr);
}
@@ -1049,7 +1054,7 @@ DoRemoveJustDirectory(
}
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
@@ -1083,7 +1088,7 @@ DoRemoveJustDirectory(
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
SetFileAttributesW(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
@@ -1109,7 +1114,10 @@ DoRemoveJustDirectory(
end:
if (errorPtr != NULL) {
- char *p = Tcl_WinTCharToUtf((TCHAR *)nativePath, -1, errorPtr);
+ char *p;
+
+ Tcl_DStringInit(errorPtr);
+ p = Tcl_WCharToUtfDString(nativePath, TCL_INDEX_NONE, errorPtr);
for (; *p; ++p) {
if (*p == '\\') *p = '/';
}
@@ -1187,7 +1195,7 @@ TraverseWinTree(
nativeErrfile = NULL;
result = TCL_OK;
- oldTargetLen = 0; /* lint. */
+ oldTargetLen = 0;
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
@@ -1227,7 +1235,7 @@ TraverseWinTree(
* Can't read directory.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
nativeErrfile = nativeSource;
goto end;
}
@@ -1256,7 +1264,7 @@ TraverseWinTree(
found = 1;
for (; found; found = FindNextFileW(handle, &data)) {
WCHAR *nativeName;
- size_t len;
+ int len;
WCHAR *wp = data.cFileName;
if (*wp == '.') {
@@ -1321,9 +1329,10 @@ TraverseWinTree(
end:
if (nativeErrfile != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (errorPtr != NULL) {
- Tcl_WinTCharToUtf((TCHAR *)nativeErrfile, -1, errorPtr);
+ Tcl_DStringInit(errorPtr);
+ Tcl_WCharToUtfDString(nativeErrfile, TCL_INDEX_NONE, errorPtr);
}
result = TCL_ERROR;
}
@@ -1375,7 +1384,7 @@ TraversalCopy(
attr) != FALSE) {
return TCL_OK;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
}
break;
case DOTREE_POSTD:
@@ -1388,7 +1397,8 @@ TraversalCopy(
*/
if (errorPtr != NULL) {
- Tcl_WinTCharToUtf((TCHAR *)nativeDst, -1, errorPtr);
+ Tcl_DStringInit(errorPtr);
+ Tcl_WCharToUtfDString(nativeDst, TCL_INDEX_NONE, errorPtr);
}
return TCL_ERROR;
}
@@ -1417,7 +1427,7 @@ TraversalCopy(
static int
TraversalDelete(
const WCHAR *nativeSrc, /* Source pathname to delete. */
- const WCHAR *dstPtr, /* Not used. */
+ TCL_UNUSED(const WCHAR *) /*dstPtr*/,
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
@@ -1443,7 +1453,8 @@ TraversalDelete(
}
if (errorPtr != NULL) {
- Tcl_WinTCharToUtf((TCHAR *)nativeSrc, -1, errorPtr);
+ Tcl_DStringInit(errorPtr);
+ Tcl_WCharToUtfDString(nativeSrc, TCL_INDEX_NONE, errorPtr);
}
return TCL_ERROR;
}
@@ -1471,7 +1482,7 @@ StatError(
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
@@ -1506,7 +1517,7 @@ GetWinFileAttributes(
const WCHAR *nativeName;
int attr;
- nativeName = (WCHAR *)Tcl_FSGetNativePath(fileName);
+ nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(nativeName);
if (result == 0xFFFFFFFF) {
@@ -1525,7 +1536,7 @@ GetWinFileAttributes(
*/
int len;
- const char *str = Tcl_GetStringFromObj(fileName,&len);
+ const char *str = TclGetStringFromObj(fileName, &len);
if (len < 4) {
if (len == 0) {
@@ -1549,7 +1560,7 @@ GetWinFileAttributes(
}
}
- *attributePtrPtr = Tcl_NewBooleanObj(attr);
+ TclNewIntObj(*attributePtrPtr, attr != 0);
return TCL_OK;
}
@@ -1579,7 +1590,7 @@ GetWinFileAttributes(
static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
+ TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
@@ -1610,12 +1621,12 @@ ConvertFileNameFormat(
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
- int pathLen;
+ int length;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
- pathv = Tcl_GetStringFromObj(elt, &pathLen);
- if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':'))
+ pathv = TclGetStringFromObj(elt, &length);
+ if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
@@ -1638,7 +1649,6 @@ ConvertFileNameFormat(
Tcl_DString dsTemp;
const WCHAR *nativeName;
const char *tempString;
- int tempLen;
WIN32_FIND_DATAW data;
HANDLE handle;
DWORD attr;
@@ -1651,9 +1661,9 @@ ConvertFileNameFormat(
* likely to lead to infinite loops.
*/
+ tempString = TclGetStringFromObj(tempPath, &length);
Tcl_DStringInit(&ds);
- tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
- nativeName = (WCHAR *)Tcl_WinUtfToTChar(tempString, tempLen, &ds);
+ nativeName = Tcl_UtfToWCharDString(tempString, length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFileW(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
@@ -1690,7 +1700,7 @@ ConvertFileNameFormat(
}
/*
- * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
+ * Purify reports a extraneous UMR in Tcl_WCharToUtfDString() trying
* to dereference nativeName as a Unicode string. I have proven to
* myself that purify is wrong by running the following example
* when nativeName == data.w.cAlternateFileName and noting that
@@ -1702,7 +1712,7 @@ ConvertFileNameFormat(
*/
Tcl_DStringInit(&dsTemp);
- Tcl_WinTCharToUtf((TCHAR *)nativeName, -1, &dsTemp);
+ Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp);
Tcl_DStringFree(&ds);
/*
@@ -1715,14 +1725,14 @@ ConvertFileNameFormat(
Tcl_DStringLength(&dsTemp));
Tcl_DStringFree(&dsTemp);
} else {
- tempPath = TclDStringToObj(&dsTemp);
+ tempPath = Tcl_DStringToObj(&dsTemp);
}
Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
FindClose(handle);
}
}
- *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
+ *attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE);
if (splitPath != NULL) {
/*
@@ -1833,7 +1843,7 @@ SetWinFileAttributes(
int yesNo, result;
const WCHAR *nativeName;
- nativeName = (WCHAR *)Tcl_FSGetNativePath(fileName);
+ nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(nativeName);
if (fileAttributes == 0xFFFFFFFF) {
@@ -1882,7 +1892,7 @@ CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
- Tcl_Obj *attributePtr) /* The new value of the attribute. */
+ TCL_UNUSED(Tcl_Obj *) /*attributePtr*/)
{
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
@@ -1926,7 +1936,7 @@ TclpObjListVolumes(void)
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
- * GetVolumeInformationW() will detect all drives, but causes
+ * GetVolumeInformationW() will detects all drives, but causes
* chattering on empty floppy drives. We only do this if
* GetLogicalDriveStrings() didn't work. It has also been reported
* that on some laptops it takes a while for GetVolumeInformationW() to
@@ -1942,14 +1952,14 @@ TclpObjListVolumes(void)
buf[0] = (char) ('a' + i);
if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
|| (GetLastError() == ERROR_NOT_READY)) {
- elemPtr = Tcl_NewStringObj(buf, -1);
+ elemPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
} else {
for (p = buf; *p != '\0'; p += 4) {
p[2] = '/';
- elemPtr = Tcl_NewStringObj(p, -1);
+ elemPtr = Tcl_NewStringObj(p, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
@@ -1959,6 +1969,121 @@ TclpObjListVolumes(void)
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateTemporaryDirectory --
+ *
+ * Creates a temporary directory, possibly based on the supplied bits and
+ * pieces of template supplied in the arguments.
+ *
+ * Results:
+ * An object (refcount 0) containing the name of the newly-created
+ * directory, or NULL on failure.
+ *
+ * Side effects:
+ * Accesses the native filesystem. Makes a directory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclpCreateTemporaryDirectory(
+ Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj)
+{
+ Tcl_DString base, name; /* Contains WCHARs */
+ int baseLen;
+ DWORD error;
+ WCHAR tempBuf[MAX_PATH + 1];
+ DWORD len = GetTempPathW(MAX_PATH, tempBuf);
+
+ /*
+ * Build the path in writable memory from the user-supplied pieces and
+ * some defaults. First, the parent temporary directory.
+ */
+
+ if (dirObj) {
+ Tcl_GetString(dirObj);
+ if (dirObj->length < 1) {
+ goto useSystemTemp;
+ }
+ Tcl_DStringInit(&base);
+ Tcl_UtfToWCharDString(Tcl_GetString(dirObj), TCL_INDEX_NONE, &base);
+ if (dirObj->bytes[dirObj->length - 1] != '\\') {
+ Tcl_UtfToWCharDString("\\", TCL_INDEX_NONE, &base);
+ }
+ } else {
+ useSystemTemp:
+ Tcl_DStringInit(&base);
+ Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
+ }
+
+ /*
+ * Next, the base of the directory name.
+ */
+
+#define DEFAULT_TEMP_DIR_PREFIX "tcl"
+#define SUFFIX_LENGTH 8
+
+ if (basenameObj) {
+ Tcl_UtfToWCharDString(Tcl_GetString(basenameObj), TCL_INDEX_NONE, &base);
+ } else {
+ Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, TCL_INDEX_NONE, &base);
+ }
+ Tcl_UtfToWCharDString("_", TCL_INDEX_NONE, &base);
+
+ /*
+ * Now we keep on trying random suffixes until we get one that works
+ * (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that
+ * SUFFIX_LENGTH is longer than on Unix because we expect to be not on a
+ * case-sensitive filesystem.
+ */
+
+ baseLen = Tcl_DStringLength(&base);
+ do {
+ char tempbuf[SUFFIX_LENGTH + 1];
+ int i;
+ static const char randChars[] =
+ "QWERTYUIOPASDFGHJKLZXCVBNM1234567890";
+ static const int numRandChars = sizeof(randChars) - 1;
+
+ /*
+ * Put a random suffix on the end.
+ */
+
+ error = ERROR_SUCCESS;
+ tempbuf[SUFFIX_LENGTH] = '\0';
+ for (i = 0 ; i < SUFFIX_LENGTH; i++) {
+ tempbuf[i] = randChars[(int) (rand() % numRandChars)];
+ }
+ Tcl_DStringSetLength(&base, baseLen);
+ Tcl_UtfToWCharDString(tempbuf, TCL_INDEX_NONE, &base);
+ } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)
+ && (error = GetLastError()) == ERROR_ALREADY_EXISTS);
+
+ /*
+ * Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and
+ * ERROR_ACCESS_DENIED.
+ */
+
+ if (error != ERROR_SUCCESS) {
+ Tcl_WinConvertError(error);
+ Tcl_DStringFree(&base);
+ return NULL;
+ }
+
+ /*
+ * We actually made the directory, so we're done! Report what we made back
+ * as a (clean) Tcl_Obj.
+ */
+
+ Tcl_DStringInit(&name);
+ Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), TCL_INDEX_NONE, &name);
+ Tcl_DStringFree(&base);
+ return Tcl_DStringToObj(&name);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 3b1ff76..adc1d7d 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -6,7 +6,7 @@
* files, which can be manipulated through the Win32 console redirection
* interfaces.
*
- * Copyright (c) 1995-1998 Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -29,7 +29,7 @@
*/
#define POSIX_EPOCH_AS_FILETIME \
- ((Tcl_WideInt) 116444736 * (Tcl_WideInt) 1000000000)
+ ((long long) 116444736 * (long long) 1000000000)
/*
* Declarations for 'link' related information. This information should come
@@ -170,7 +170,7 @@ static int NativeWriteReparse(const WCHAR *LinkDirectory,
static int NativeMatchType(int isDrive, DWORD attr,
const WCHAR *nativeName, Tcl_GlobTypeData *types);
static int WinIsDrive(const char *name, size_t nameLen);
-static int WinIsReserved(const char *path);
+static size_t WinIsReserved(const char *path);
static Tcl_Obj * WinReadLink(const WCHAR *LinkSource);
static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory);
static int WinLink(const WCHAR *LinkSource,
@@ -209,7 +209,7 @@ WinLink(
* Invalid file.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
@@ -233,7 +233,7 @@ WinLink(
* Invalid file.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
@@ -247,7 +247,7 @@ WinLink(
* The target doesn't exist.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* It is a file.
@@ -262,14 +262,9 @@ WinLink(
return 0;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
- if (!tclWinProcs.createSymbolicLink) {
- /*
- * Can't symlink files.
- */
- Tcl_SetErrno(EINVAL);
- } else if (tclWinProcs.createSymbolicLink(linkSourcePath, linkTargetPath,
+ if (CreateSymbolicLinkW(linkSourcePath, linkTargetPath,
0x2 /* SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE */)) {
/*
* Success!
@@ -277,7 +272,7 @@ WinLink(
return 0;
} else {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
}
} else {
Tcl_SetErrno(ENODEV);
@@ -332,7 +327,7 @@ WinReadLink(
* Invalid file.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return NULL;
}
@@ -346,7 +341,7 @@ WinReadLink(
* The source doesn't exist.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return NULL;
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
@@ -507,7 +502,7 @@ TclWinSymLinkDelete(
* Error setting junction.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
CloseHandle(hFile);
} else {
CloseHandle(hFile);
@@ -644,10 +639,11 @@ WinReadLinkDirectory(
}
}
- Tcl_WinTCharToUtf((TCHAR *)
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString(
reparseBuffer->MountPointReparseBuffer.PathBuffer,
reparseBuffer->MountPointReparseBuffer
- .SubstituteNameLength, &ds);
+ .SubstituteNameLength>>1, &ds);
copy = Tcl_DStringValue(&ds)+offset;
len = Tcl_DStringLength(&ds)-offset;
@@ -699,7 +695,7 @@ NativeReadReparse(
* Error creating directory.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
@@ -713,7 +709,7 @@ NativeReadReparse(
* Error setting junction.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
CloseHandle(hFile);
return -1;
}
@@ -755,7 +751,7 @@ NativeWriteReparse(
* Error creating directory.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
hFile = CreateFileW(linkDirPath, GENERIC_WRITE, 0, NULL,
@@ -766,7 +762,7 @@ NativeWriteReparse(
* Error creating directory.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
@@ -781,7 +777,7 @@ NativeWriteReparse(
* Error setting junction.
*/
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
CloseHandle(hFile);
RemoveDirectoryW(linkDirPath);
return -1;
@@ -885,13 +881,14 @@ TclpFindExecutable(
*/
if (argv0 == NULL) {
+# undef Tcl_SetPanicProc
Tcl_SetPanicProc(tclWinDebugPanic);
}
GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR));
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
- TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
+ TclSetObjNameOfExecutable(Tcl_NewStringObj(name, TCL_INDEX_NONE), NULL);
}
/*
@@ -941,12 +938,12 @@ TclpMatchInDirectory(
* Match a single file directly.
*/
- int len;
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
- const char *str = Tcl_GetStringFromObj(norm,&len);
+ Tcl_Size len = 0;
+ const char *str = TclGetStringFromObj(norm, &len);
- native = (WCHAR *)Tcl_FSGetNativePath(pathPtr);
+ native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
@@ -954,7 +951,7 @@ TclpMatchInDirectory(
}
attr = data.dwFileAttributes;
- if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) {
+ if (NativeMatchType(WinIsDrive(str, len), attr, native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
@@ -965,7 +962,7 @@ TclpMatchInDirectory(
WIN32_FIND_DATAW data;
const char *dirName; /* UTF-8 dir name, later with pattern
* appended. */
- int dirLength;
+ Tcl_Size dirLength;
int matchSpecialDots;
Tcl_DString ds; /* Native encoding of dir, also used
* temporarily for other things. */
@@ -1004,7 +1001,7 @@ TclpMatchInDirectory(
*/
Tcl_DStringInit(&dsOrig);
- dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
+ dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
@@ -1027,12 +1024,13 @@ TclpMatchInDirectory(
* pattern.
*/
- dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
+ dirName = Tcl_DStringAppend(&dsOrig, pattern, TCL_INDEX_NONE);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
- native = (WCHAR *)Tcl_WinUtfToTChar(dirName, -1, &ds);
+ Tcl_DStringInit(&ds);
+ native = Tcl_UtfToWCharDString(dirName, TCL_INDEX_NONE, &ds);
if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
handle = FindFirstFileW(native, &data);
} else {
@@ -1059,7 +1057,7 @@ TclpMatchInDirectory(
return TCL_OK;
}
- TclWinConvertError(err);
+ Tcl_WinConvertError(err);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
@@ -1104,7 +1102,8 @@ TclpMatchInDirectory(
native = data.cFileName;
attr = data.dwFileAttributes;
- utfname = Tcl_WinTCharToUtf((TCHAR *)native, -1, &ds);
+ Tcl_DStringInit(&ds);
+ utfname = Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, &ds);
if (!matchSpecialDots) {
/*
@@ -1246,7 +1245,7 @@ WinIsDrive(
* (not any trailing :).
*/
-static int
+static size_t
WinIsReserved(
const char *path) /* Path in UTF-8 */
{
@@ -1486,9 +1485,7 @@ TclpGetUserHome(
HANDLE hToken;
if (OpenProcessToken(hProcess, TOKEN_QUERY, &hToken)) {
if (GetUserProfileDirectoryW(hToken, buf, &nChars)) {
- Tcl_WinTCharToUtf((TCHAR *)buf,
- (nChars-1)*sizeof(WCHAR), bufferPtr);
- result = Tcl_DStringValue(bufferPtr);
+ result = Tcl_WCharToUtfDString(buf, nChars-1, (bufferPtr));
rc = 1;
}
CloseHandle(hToken);
@@ -1497,13 +1494,15 @@ TclpGetUserHome(
}
Tcl_DStringFree(&ds);
} else {
- wName = (WCHAR *)Tcl_WinUtfToTChar(domain + 1, -1, &ds);
+ Tcl_DStringInit(&ds);
+ wName = Tcl_UtfToWCharDString(domain + 1, TCL_INDEX_NONE, &ds);
rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain);
Tcl_DStringFree(&ds);
nameLen = domain - name;
}
if (rc == 0) {
- wName = (WCHAR *)Tcl_WinUtfToTChar(name, nameLen, &ds);
+ Tcl_DStringInit(&ds);
+ wName = Tcl_UtfToWCharDString(name, nameLen, &ds);
while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
/*
* User does not exist; if domain was not specified, try again
@@ -1531,7 +1530,7 @@ TclpGetUserHome(
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) {
size = lstrlenW(wHomeDir);
- Tcl_WinTCharToUtf((TCHAR *)wHomeDir, size*sizeof(WCHAR), bufferPtr);
+ Tcl_WCharToUtfDString(wHomeDir, size, bufferPtr);
} else {
WCHAR buf[MAX_PATH];
/*
@@ -1540,7 +1539,7 @@ TclpGetUserHome(
*/
GetProfilesDirectoryW(buf, &size);
- Tcl_WinTCharToUtf((TCHAR *)buf, (size-1)*sizeof(WCHAR), bufferPtr);
+ Tcl_WCharToUtfDString(buf, size-1, bufferPtr);
Tcl_DStringAppend(bufferPtr, "/", 1);
Tcl_DStringAppend(bufferPtr, name, nameLen);
}
@@ -1601,7 +1600,7 @@ NativeAccess(
DWORD lasterror = GetLastError();
if (lasterror != ERROR_SHARING_VIOLATION) {
- TclWinConvertError(lasterror);
+ Tcl_WinConvertError(lasterror);
return -1;
}
}
@@ -1727,7 +1726,7 @@ NativeAccess(
* to EACCES - just what we want!
*/
- TclWinConvertError((DWORD) error);
+ Tcl_WinConvertError((DWORD) error);
return -1;
}
@@ -1832,7 +1831,7 @@ NativeAccess(
*/
accessError:
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (sdPtr != NULL) {
HeapFree(GetProcessHeap(), 0, sdPtr);
}
@@ -1875,7 +1874,7 @@ static int
NativeIsExec(
const WCHAR *path)
{
- size_t len = wcslen(path);
+ int len = wcslen(path);
if (len < 5) {
return 0;
@@ -1926,7 +1925,7 @@ TclpObjChdir(
result = SetCurrentDirectoryW(nativePath);
if (result == 0) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
return 0;
@@ -1965,7 +1964,7 @@ TclpGetCwd(
WCHAR *native;
if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
@@ -1983,7 +1982,8 @@ TclpGetCwd(
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
- Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
+ Tcl_DStringInit(bufferPtr);
+ Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
@@ -2095,8 +2095,8 @@ NativeStat(
statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
attr = data.dwFileAttributes;
- statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) |
- (((Tcl_WideInt) data.nFileSizeHigh) << 32);
+ statPtr->st_size = ((long long) data.nFileSizeLow) |
+ (((long long) data.nFileSizeHigh) << 32);
/*
* On Unix, for directories, nlink apparently depends on the number of
@@ -2129,12 +2129,12 @@ NativeStat(
DWORD lasterror = GetLastError();
if (lasterror != ERROR_SHARING_VIOLATION) {
- TclWinConvertError(lasterror);
+ Tcl_WinConvertError(lasterror);
return -1;
}
hFind = FindFirstFileW(nativePath, &ffd);
if (hFind == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return -1;
}
memcpy(&data, &ffd, sizeof(data));
@@ -2143,8 +2143,8 @@ NativeStat(
attr = data.dwFileAttributes;
- statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) |
- (((Tcl_WideInt) data.nFileSizeHigh) << 32);
+ statPtr->st_size = ((long long) data.nFileSizeLow) |
+ (((long long) data.nFileSizeHigh) << 32);
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
@@ -2191,7 +2191,8 @@ NativeDev(
const char *fullPath;
GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart);
- fullPath = Tcl_WinTCharToUtf((TCHAR *)nativeFullPath, -1, &ds);
+ Tcl_DStringInit(&ds);
+ fullPath = Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
@@ -2212,7 +2213,8 @@ NativeDev(
} else {
p++;
}
- nativeVol = (WCHAR *)Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
+ Tcl_DStringInit(&volString);
+ nativeVol = Tcl_UtfToWCharDString(fullPath, p - fullPath, &volString);
dw = (DWORD) -1;
GetVolumeInformationW(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0);
@@ -2304,7 +2306,7 @@ ToCTime(
convertedTime.HighPart = (LONG) fileTime.dwHighDateTime;
return (time_t) ((convertedTime.QuadPart -
- (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000);
+ (long long) POSIX_EPOCH_AS_FILETIME) / (long long) 10000000);
}
/*
@@ -2354,14 +2356,14 @@ FromCTime(
*----------------------------------------------------------------------
*/
-ClientData
+void *
TclpGetNativeCwd(
- ClientData clientData)
+ void *clientData)
{
WCHAR buffer[MAX_PATH];
if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return NULL;
}
@@ -2492,8 +2494,9 @@ TclpFilesystemPathType(
} else {
Tcl_DString ds;
- Tcl_WinTCharToUtf((TCHAR *)volType, -1, &ds);
- return TclDStringToObj(&ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString(volType, TCL_INDEX_NONE, &ds);
+ return Tcl_DStringToObj(&ds);
}
#undef VOL_BUF_SIZE
}
@@ -2535,7 +2538,7 @@ TclpFilesystemPathType(
int
TclpObjNormalizePath(
- Tcl_Interp *interp, /* not used */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize */
int nextCheckpoint) /* offset to start at in pathPtr */
@@ -2546,7 +2549,6 @@ TclpObjNormalizePath(
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds; /* Some workspace. */
- (void)interp;
Tcl_DStringInit(&dsNorm);
path = Tcl_GetString(pathPtr);
@@ -2564,7 +2566,10 @@ TclpObjNormalizePath(
*/
WIN32_FILE_ATTRIBUTE_DATA data;
- const WCHAR *nativePath = (WCHAR *)Tcl_WinUtfToTChar(path,
+ const WCHAR *nativePath;
+
+ Tcl_DStringInit(&ds);
+ nativePath = Tcl_UtfToWCharDString(path,
currentPathEndPosition - path, &ds);
if (GetFileAttributesExW(nativePath,
@@ -2574,14 +2579,14 @@ TclpObjNormalizePath(
*/
if (isDrive) {
- int len = WinIsReserved(path);
+ size_t len = WinIsReserved(path);
if (len > 0) {
/*
* Actually it does exist - COM1, etc.
*/
- int i;
+ size_t i;
for (i=0 ; i<len ; i++) {
WCHAR wc = ((WCHAR *)nativePath)[i];
@@ -2593,7 +2598,7 @@ TclpObjNormalizePath(
}
Tcl_DStringAppend(&dsNorm,
(const char *)nativePath,
- (int)(sizeof(WCHAR) * len));
+ sizeof(WCHAR) * len);
lastValidPathEnd = currentPathEndPosition;
} else if (nextCheckpoint == 0) {
/*
@@ -2638,7 +2643,7 @@ TclpObjNormalizePath(
*/
nextCheckpoint = 0;
- Tcl_AppendToObj(to, currentPathEndPosition, -1);
+ Tcl_AppendToObj(to, currentPathEndPosition, TCL_INDEX_NONE);
/*
* Convert link to forward slashes.
@@ -2739,7 +2744,7 @@ TclpObjNormalizePath(
sizeof(WCHAR));
Tcl_DStringAppend(&dsNorm,
(const char *) nativeName,
- (int) (wcslen(nativeName)*sizeof(WCHAR)));
+ wcslen(nativeName)*sizeof(WCHAR));
}
}
}
@@ -2766,11 +2771,14 @@ TclpObjNormalizePath(
if (1) {
WCHAR wpath[MAX_PATH];
- const WCHAR *nativePath =
- Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
- DWORD wpathlen = GetLongPathNameProc(nativePath,
- (WCHAR *) wpath, MAX_PATH);
+ const WCHAR *nativePath;
+ DWORD wpathlen;
+ Tcl_DStringInit(&ds);
+ nativePath =
+ Tcl_UtfToWCharDString(path, lastValidPathEnd - path, &ds);
+ wpathlen = GetLongPathNameProc(nativePath,
+ (WCHAR *) wpath, MAX_PATH);
/*
* We have to make the drive letter uppercase.
*/
@@ -2797,21 +2805,22 @@ TclpObjNormalizePath(
* native encoding, so we have to convert it to Utf.
*/
- Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&dsNorm),
- Tcl_DStringLength(&dsNorm), &ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString((const WCHAR *) Tcl_DStringValue(&dsNorm),
+ Tcl_DStringLength(&dsNorm)>>1, &ds);
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
- int len;
Tcl_Obj *tmpPathPtr;
+ Tcl_Size len;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
- Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
- path = Tcl_GetStringFromObj(tmpPathPtr, &len);
+ Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE);
+ path = TclGetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
@@ -2883,7 +2892,7 @@ TclWinVolumeRelativeNormalize(
const char *drive = Tcl_GetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
- Tcl_AppendToObj(absolutePath, path, -1);
+ Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE);
Tcl_IncrRefCount(absolutePath);
/*
@@ -2895,9 +2904,8 @@ TclWinVolumeRelativeNormalize(
* also on drive C.
*/
- int cwdLen;
- const char *drive =
- Tcl_GetStringFromObj(useThisCwd, &cwdLen);
+ Tcl_Size cwdLen;
+ const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
if (drive_cur >= 'a') {
@@ -2937,7 +2945,7 @@ TclWinVolumeRelativeNormalize(
Tcl_AppendToObj(absolutePath, "/", 1);
}
Tcl_IncrRefCount(absolutePath);
- Tcl_AppendToObj(absolutePath, path+2, -1);
+ Tcl_AppendToObj(absolutePath, path+2, TCL_INDEX_NONE);
}
*useThisCwdPtr = useThisCwd;
return absolutePath;
@@ -2966,14 +2974,15 @@ TclWinVolumeRelativeNormalize(
Tcl_Obj *
TclpNativeToNormalized(
- ClientData clientData)
+ void *clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
- int len;
+ Tcl_Size len;
char *copy, *p;
- Tcl_WinTCharToUtf((TCHAR *) clientData, -1, &ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString((const WCHAR *) clientData, TCL_INDEX_NONE, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
@@ -3025,14 +3034,14 @@ TclpNativeToNormalized(
*---------------------------------------------------------------------------
*/
-ClientData
+void *
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
WCHAR *nativePathPtr = NULL;
const char *str;
Tcl_Obj *validPathPtr;
- size_t len;
+ Tcl_Size len;
WCHAR *wp;
if (TclFSCwdIsNative()) {
@@ -3069,10 +3078,9 @@ TclNativeCreateNativeRep(
Tcl_IncrRefCount(validPathPtr);
}
- str = Tcl_GetString(validPathPtr);
- len = validPathPtr->length;
+ str = TclGetStringFromObj(validPathPtr, &len);
- if (strlen(str) != len) {
+ if (strlen(str) != (size_t)len) {
/*
* String contains NUL-bytes. This is invalid.
*/
@@ -3187,9 +3195,9 @@ TclNativeCreateNativeRep(
*---------------------------------------------------------------------------
*/
-ClientData
+void *
TclNativeDupInternalRep(
- ClientData clientData)
+ void *clientData)
{
char *copy;
size_t len;
@@ -3255,7 +3263,7 @@ TclpUtime(
if (fileHandle == INVALID_HANDLE_VALUE ||
!SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
res = -1;
}
if (fileHandle != INVALID_HANDLE_VALUE) {
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index d512e73..c085c81 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -3,8 +3,8 @@
*
* Contains the Windows-specific interpreter initialization functions.
*
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
* All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
@@ -36,11 +36,6 @@ typedef struct {
} OemId;
/*
- * Windows version dependend functions
- */
-TclWinProcs tclWinProcs;
-
-/*
* The following arrays contain the human readable strings for the
* processor values.
*/
@@ -89,7 +84,6 @@ TclpInitPlatform(void)
{
WSADATA wsaData;
WORD wVersionRequested = MAKEWORD(2, 2);
- HMODULE handle;
tclPlatform = TCL_PLATFORM_WINDOWS;
@@ -108,17 +102,6 @@ TclpInitPlatform(void)
TclWinInit(GetModuleHandleW(NULL));
#endif
-
- /*
- * Fill available functions depending on windows version
- */
- handle = GetModuleHandleW(L"KERNEL32");
- tclWinProcs.cancelSynchronousIo =
- (BOOL (WINAPI *)(HANDLE))(void *)GetProcAddress(handle,
- "CancelSynchronousIo");
- tclWinProcs.createSymbolicLink =
- (BOOLEAN (WINAPI *)(LPCWSTR, LPCWSTR, DWORD))(void *)GetProcAddress(handle,
- "CreateSymbolicLinkW");
}
/*
@@ -141,13 +124,14 @@ TclpInitPlatform(void)
void
TclpInitLibraryPath(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
+ int length;
TclNewObj(pathPtr);
@@ -183,9 +167,10 @@ TclpInitLibraryPath(
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
- bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
- *valuePtr = (char *)ckalloc(*lengthPtr + 1);
- memcpy(*valuePtr, bytes, *lengthPtr + 1);
+ bytes = TclGetStringFromObj(pathPtr, &length);
+ *lengthPtr = length++;
+ *valuePtr = (char *)ckalloc(length);
+ memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
@@ -248,7 +233,7 @@ AppendEnvironment(
WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);
if (buf[0] != '\0') {
- objPtr = Tcl_NewStringObj(buf, -1);
+ objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
@@ -270,9 +255,9 @@ AppendEnvironment(
pathv[pathc - 1] = shortlib;
Tcl_DStringInit(&ds);
(void) Tcl_JoinPath(pathc, pathv, &ds);
- objPtr = TclDStringToObj(&ds);
+ objPtr = Tcl_DStringToObj(&ds);
} else {
- objPtr = Tcl_NewStringObj(buf, -1);
+ objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
ckfree(pathv);
@@ -299,7 +284,7 @@ AppendEnvironment(
static void
InitializeDefaultLibraryDir(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
@@ -347,7 +332,7 @@ InitializeDefaultLibraryDir(
static void
InitializeSourceLibraryDir(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
@@ -408,12 +393,6 @@ TclpSetInitialEncodings(void)
Tcl_DStringFree(&encodingName);
}
-void TclWinSetInterfaces(
- int dummy) /* Not used. */
-{
- (void)dummy;
-}
-
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
@@ -446,8 +425,8 @@ TclpGetUserName(
return NULL;
}
cchUserNameLen--;
- cchUserNameLen *= sizeof(WCHAR);
- Tcl_WinTCharToUtf((TCHAR *)szUserName, cchUserNameLen, bufferPtr);
+ Tcl_DStringInit(bufferPtr);
+ Tcl_WCharToUtfDString(szUserName, cchUserNameLen, bufferPtr);
}
return Tcl_DStringValue(bufferPtr);
}
@@ -517,7 +496,8 @@ TclpSetVariables(
TCL_GLOBAL_ONLY);
}
-#ifndef NDEBUG
+#if !defined(NDEBUG) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
@@ -540,11 +520,11 @@ TclpSetVariables(
if (ptr == NULL) {
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
- Tcl_DStringAppend(&ds, ptr, -1);
+ Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
- Tcl_DStringAppend(&ds, ptr, -1);
+ Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
@@ -599,6 +579,9 @@ TclpSetVariables(
*----------------------------------------------------------------------
*/
+# define tenviron2utfdstr(string, len, dsPtr) \
+ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))
+
int
TclpFindVariable(
const char *name, /* Name of desired environment variable
@@ -633,7 +616,8 @@ TclpFindVariable(
* after the equal sign.
*/
- envUpper = Tcl_WinTCharToUtf((TCHAR *)env, -1, &envString);
+ Tcl_DStringInit(&envString);
+ envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index b7974b8..d5cf7b0 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -32,42 +32,6 @@ typedef struct TCLEXCEPTION_REGISTRATION {
#endif
/*
- * Windows version dependend functions
- */
-typedef struct TclWinProcs {
- BOOL (WINAPI *cancelSynchronousIo)(HANDLE);
- BOOLEAN (WINAPI *createSymbolicLink)(LPCWSTR, LPCWSTR, DWORD);
-} TclWinProcs;
-
-MODULE_SCOPE TclWinProcs tclWinProcs;
-
-/*
- * Some versions of Borland C have a define for the OSVERSIONINFO for
- * Win32s and for NT, but not for Windows 95.
- * Define VER_PLATFORM_WIN32_CE for those without newer headers.
- */
-
-#ifndef VER_PLATFORM_WIN32_WINDOWS
-#define VER_PLATFORM_WIN32_WINDOWS 1
-#endif
-#ifndef VER_PLATFORM_WIN32_CE
-#define VER_PLATFORM_WIN32_CE 3
-#endif
-
-#ifndef TCL_Z_MODIFIER
-# ifdef _WIN64
-# if defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO
-# define TCL_Z_MODIFIER "ll"
-# else
-# define TCL_Z_MODIFIER "I"
-# endif
-# else
-# define TCL_Z_MODIFIER ""
-# endif
-#endif
-#define TCL_I_MODIFIER TCL_Z_MODIFIER
-
-/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
@@ -88,13 +52,6 @@ MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal,
MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal,
int linkOnly);
MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *);
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
-MODULE_SCOPE void TclWinFreeAllocCache(void);
-MODULE_SCOPE void TclFreeAllocCache(void *);
-MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
-MODULE_SCOPE void * TclpGetAllocCache(void);
-MODULE_SCOPE void TclpSetAllocCache(void *);
-#endif /* TCL_THREADS */
MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr);
@@ -117,7 +74,7 @@ typedef struct TclPipeThreadInfo {
* to do read/write operation. Additionally
* used as signal to stop (state set to -1) */
volatile LONG state; /* Indicates current state of the thread */
- ClientData clientData; /* Referenced data of the main thread */
+ void *clientData; /* Referenced data of the main thread */
HANDLE evWakeUp; /* Optional wake-up event worker set by shutdown */
} TclPipeThreadInfo;
@@ -144,7 +101,7 @@ typedef struct TclPipeThreadInfo {
MODULE_SCOPE
TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
- ClientData clientData, HANDLE wakeEvent);
+ void *clientData, HANDLE wakeEvent);
MODULE_SCOPE int TclPipeThreadWaitForSignal(TclPipeThreadInfo **pipeTIPtr);
static inline void
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 9d2d87e..df49337 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -5,7 +5,7 @@
* the Windows "LoadLibrary" and "GetProcAddress" API for dynamic
* loading.
*
- * 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.
@@ -20,7 +20,9 @@
*/
static WCHAR *dllDirectoryName = NULL;
+#if TCL_THREADS
static Tcl_Mutex dllDirectoryNameMutex;
+#endif
/*
* Static functions defined within this file.
@@ -61,13 +63,12 @@ TclpDlopen(
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
HINSTANCE hInstance = NULL;
const WCHAR *nativeName;
Tcl_LoadHandle handlePtr;
DWORD firstError;
- (void)flags;
/*
* First try the full path the user gave us. This is particularly
@@ -96,7 +97,8 @@ TclpDlopen(
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
- nativeName = (WCHAR *)Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
+ Tcl_DStringInit(&ds);
+ nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds);
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
@@ -137,31 +139,31 @@ TclpDlopen(
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL);
notFoundMsg:
Tcl_AppendToObj(errMsg, "this library or a dependent library"
- " could not be found in library path", -1);
+ " could not be found in library path", TCL_INDEX_NONE);
break;
case ERROR_PROC_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL);
Tcl_AppendToObj(errMsg, "A function specified in the import"
" table could not be resolved by the system. Windows"
- " is not telling which one, I'm sorry.", -1);
+ " is not telling which one, I'm sorry.", TCL_INDEX_NONE);
break;
case ERROR_INVALID_DLL:
Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL);
Tcl_AppendToObj(errMsg, "this library or a dependent library"
- " is damaged", -1);
+ " is damaged", TCL_INDEX_NONE);
break;
case ERROR_DLL_INIT_FAILED:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL);
Tcl_AppendToObj(errMsg, "the library initialization"
- " routine failed", -1);
+ " routine failed", TCL_INDEX_NONE);
break;
case ERROR_BAD_EXE_FORMAT:
Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", NULL);
- Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", -1);
+ Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE);
break;
default:
- TclWinConvertError(lastError);
- Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1);
+ Tcl_WinConvertError(lastError);
+ Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE);
}
Tcl_SetObjResult(interp, errMsg);
}
@@ -218,7 +220,7 @@ FindSymbol(
Tcl_DStringInit(&ds);
TclDStringAppendLiteral(&ds, "_");
- sym2 = Tcl_DStringAppend(&ds, symbol, -1);
+ sym2 = Tcl_DStringAppend(&ds, symbol, TCL_INDEX_NONE);
proc = (void *)GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
@@ -263,39 +265,6 @@ UnloadFile(
/*
*----------------------------------------------------------------------
*
- * TclGuessPackageName --
- *
- * If the "load" command is invoked without providing a package name,
- * this function 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. */
-{
- (void)fileName;
- (void)bufPtr;
-
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclpTempFileNameForLibrary --
*
* Constructs a temporary file name for loading a shared object (DLL).
@@ -413,7 +382,7 @@ InitDLLDirectoryName(void)
id *= 16777619;
}
- TclWinConvertError(lastError);
+ Tcl_WinConvertError(lastError);
return TCL_ERROR;
/*
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 83db956..7b7ef1e 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.c
@@ -5,7 +5,7 @@
* 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 © 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.
@@ -27,7 +27,7 @@
* created for each thread that is using the notifier.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
CRITICAL_SECTION crit; /* Monitor for this notifier. */
DWORD thread; /* Identifier for thread associated with this
* notifier. */
@@ -36,7 +36,6 @@ typedef struct ThreadSpecificData {
int pending; /* Alert message pending, this field is locked
* by the notifierMutex. */
HWND hwnd; /* Messaging window. */
- int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
} ThreadSpecificData;
@@ -50,8 +49,9 @@ static Tcl_ThreadDataKey dataKey;
*/
static int notifierCount = 0;
-static const WCHAR classname[] = L"TclNotifier";
-TCL_DECLARE_MUTEX(notifierMutex)
+static const WCHAR className[] = L"TclNotifier";
+static int initialized = 0;
+static CRITICAL_SECTION notifierMutex;
/*
* Static routines defined in this file.
@@ -77,57 +77,62 @@ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message,
*/
ClientData
-Tcl_InitNotifier(void)
+TclpInitNotifier(void)
{
- if (tclNotifierHooks.initNotifierProc) {
- return tclNotifierHooks.initNotifierProc();
- } else {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- WNDCLASSW windowClass;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- /*
- * Register Notifier window class if this is the first thread to use
- * this module.
- */
+ TclpGlobalLock();
+ if (!initialized) {
+ initialized = 1;
+ InitializeCriticalSection(&notifierMutex);
+ }
+ TclpGlobalUnlock();
- Tcl_MutexLock(&notifierMutex);
- if (notifierCount == 0) {
- windowClass.style = 0;
- windowClass.cbClsExtra = 0;
- windowClass.cbWndExtra = 0;
- windowClass.hInstance = TclWinGetTclInstance();
- windowClass.hbrBackground = NULL;
- windowClass.lpszMenuName = NULL;
- windowClass.lpszClassName = classname;
- windowClass.lpfnWndProc = NotifierProc;
- windowClass.hIcon = NULL;
- windowClass.hCursor = NULL;
-
- if (!RegisterClassW(&windowClass)) {
- Tcl_Panic("Unable to register TclNotifier window class");
- }
+ /*
+ * Register Notifier window class if this is the first thread to use this
+ * module.
+ */
+
+ EnterCriticalSection(&notifierMutex);
+ if (notifierCount == 0) {
+ WNDCLASSW clazz;
+
+ clazz.style = 0;
+ clazz.cbClsExtra = 0;
+ clazz.cbWndExtra = 0;
+ clazz.hInstance = TclWinGetTclInstance();
+ clazz.hbrBackground = NULL;
+ clazz.lpszMenuName = NULL;
+ clazz.lpszClassName = className;
+ clazz.lpfnWndProc = NotifierProc;
+ clazz.hIcon = NULL;
+ clazz.hCursor = NULL;
+
+ if (!RegisterClassW(&clazz)) {
+ Tcl_Panic("Tcl_InitNotifier: %s",
+ "unable to register TclNotifier window class");
}
- notifierCount++;
- Tcl_MutexUnlock(&notifierMutex);
+ }
+ notifierCount++;
+ LeaveCriticalSection(&notifierMutex);
- tsdPtr->pending = 0;
- tsdPtr->timerActive = 0;
+ tsdPtr->pending = 0;
+ tsdPtr->timerActive = 0;
- InitializeCriticalSection(&tsdPtr->crit);
+ InitializeCriticalSection(&tsdPtr->crit);
- tsdPtr->hwnd = NULL;
- tsdPtr->thread = GetCurrentThreadId();
- tsdPtr->event = CreateEventW(NULL, TRUE /* manual */,
- FALSE /* !signaled */, NULL);
+ tsdPtr->hwnd = NULL;
+ tsdPtr->thread = GetCurrentThreadId();
+ tsdPtr->event = CreateEventW(NULL, TRUE /* manual */,
+ FALSE /* !signaled */, NULL);
- return tsdPtr;
- }
+ return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_FinalizeNotifier --
+ * TclpFinalizeNotifier --
*
* This function is called to cleanup the notifier state before a thread
* is terminated.
@@ -142,60 +147,57 @@ Tcl_InitNotifier(void)
*/
void
-Tcl_FinalizeNotifier(
+TclpFinalizeNotifier(
ClientData clientData) /* Pointer to notifier data. */
{
- if (tclNotifierHooks.finalizeNotifierProc) {
- tclNotifierHooks.finalizeNotifierProc(clientData);
- return;
- } else {
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
- /*
- * Only finalize the notifier if a notifier was installed in the
- * current thread; there is a route in which this is not guaranteed to
- * be true (when tclWin32Dll.c:DllMain() is called with the flag
- * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread
- * that's never previously been involved with Tcl, e.g. the task
- * manager) so this check is important.
- *
- * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
- */
+ /*
+ * Only finalize the notifier if a notifier was installed in the current
+ * thread; there is a route in which this is not guaranteed to be true
+ * (when tclWin32Dll.c:DllMain() is called with the flag
+ * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread
+ * that's never previously been involved with Tcl, e.g. the task manager)
+ * so this check is important.
+ *
+ * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
+ */
- if (tsdPtr == NULL) {
- return;
- }
+ if (tsdPtr == NULL) {
+ return;
+ }
- DeleteCriticalSection(&tsdPtr->crit);
- CloseHandle(tsdPtr->event);
+ DeleteCriticalSection(&tsdPtr->crit);
+ CloseHandle(tsdPtr->event);
- /*
- * Clean up the timer and messaging window for this thread.
- */
+ /*
+ * Clean up the timer and messaging window for this thread.
+ */
- if (tsdPtr->hwnd) {
- KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
- DestroyWindow(tsdPtr->hwnd);
- }
+ if (tsdPtr->hwnd) {
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
+ DestroyWindow(tsdPtr->hwnd);
+ }
- /*
- * If this is the last thread to use the notifier, unregister the
- * notifier window class.
- */
+ /*
+ * If this is the last thread to use the notifier, unregister the notifier
+ * window class.
+ */
- Tcl_MutexLock(&notifierMutex);
+ EnterCriticalSection(&notifierMutex);
+ if (notifierCount) {
notifierCount--;
if (notifierCount == 0) {
- UnregisterClassW(classname, TclWinGetTclInstance());
+ UnregisterClassW(className, TclWinGetTclInstance());
}
- Tcl_MutexUnlock(&notifierMutex);
}
+ LeaveCriticalSection(&notifierMutex);
}
/*
*----------------------------------------------------------------------
*
- * 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
@@ -215,42 +217,37 @@ Tcl_FinalizeNotifier(
*/
void
-Tcl_AlertNotifier(
+TclpAlertNotifier(
ClientData clientData) /* Pointer to thread data. */
{
- if (tclNotifierHooks.alertNotifierProc) {
- tclNotifierHooks.alertNotifierProc(clientData);
- return;
- } else {
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+ /*
+ * Note that we do not need to lock around access to the hwnd because the
+ * race condition has no effect since any race condition implies that the
+ * notifier thread is already awake.
+ */
+
+ if (tsdPtr->hwnd) {
/*
- * Note that we do not need to lock around access to the hwnd because
- * the race condition has no effect since any race condition implies
- * that the notifier thread is already awake.
+ * We do need to lock around access to the pending flag.
*/
- if (tsdPtr->hwnd) {
- /*
- * We do need to lock around access to the pending flag.
- */
-
- EnterCriticalSection(&tsdPtr->crit);
- if (!tsdPtr->pending) {
- PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
- }
- tsdPtr->pending = 1;
- LeaveCriticalSection(&tsdPtr->crit);
- } else {
- SetEvent(tsdPtr->event);
+ EnterCriticalSection(&tsdPtr->crit);
+ if (!tsdPtr->pending) {
+ PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
}
+ tsdPtr->pending = 1;
+ LeaveCriticalSection(&tsdPtr->crit);
+ } else {
+ SetEvent(tsdPtr->event);
}
}
/*
*----------------------------------------------------------------------
*
- * Tcl_SetTimer --
+ * TclpSetTimer --
*
* This procedure sets the current notifier timer value. The notifier
* will ensure that Tcl_ServiceAll() is called after the specified
@@ -266,55 +263,49 @@ Tcl_AlertNotifier(
*/
void
-Tcl_SetTimer(
+TclpSetTimer(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
- if (tclNotifierHooks.setTimerProc) {
- tclNotifierHooks.setTimerProc(timePtr);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ UINT timeout;
+
+ /*
+ * We only need to set up an interval timer if we're being called from an
+ * external event loop. If we don't have a window handle then we just
+ * return immediately and let Tcl_WaitForEvent handle timeouts.
+ */
+
+ if (!tsdPtr->hwnd) {
return;
- } else {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- UINT timeout;
+ }
+ if (!timePtr) {
+ timeout = 0;
+ } else {
/*
- * We only need to set up an interval timer if we're being called from
- * an external event loop. If we don't have a window handle then we
- * just return immediately and let Tcl_WaitForEvent handle timeouts.
+ * Make sure we pass a non-zero value into the timeout argument.
+ * Windows seems to get confused by zero length timers.
*/
- if (!tsdPtr->hwnd) {
- return;
+ timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
+ if (timeout == 0) {
+ timeout = 1;
}
+ }
- if (!timePtr) {
- timeout = 0;
- } else {
- /*
- * Make sure we pass a non-zero value into the timeout argument.
- * Windows seems to get confused by zero length timers.
- */
-
- timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
- if (timeout == 0) {
- timeout = 1;
- }
- }
- tsdPtr->timeout = timeout;
- if (timeout != 0) {
- tsdPtr->timerActive = 1;
- SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
- (unsigned long) tsdPtr->timeout, NULL);
- } else {
- tsdPtr->timerActive = 0;
- KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
- }
+ if (timeout != 0) {
+ tsdPtr->timerActive = 1;
+ SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, timeout, NULL);
+ } else {
+ tsdPtr->timerActive = 0;
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
}
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ServiceModeHook --
+ * TclpServiceModeHook --
*
* This function is invoked whenever the service mode changes.
*
@@ -329,46 +320,65 @@ Tcl_SetTimer(
*/
void
-Tcl_ServiceModeHook(
+TclpServiceModeHook(
int mode) /* Either TCL_SERVICE_ALL, or
* TCL_SERVICE_NONE. */
{
- if (tclNotifierHooks.serviceModeHookProc) {
- tclNotifierHooks.serviceModeHookProc(mode);
- return;
- } else {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- /*
- * If this is the first time that the notifier has been used from a
- * modal loop, then create a communication window. Note that after this
- * point, the application needs to service events in a timely fashion
- * or Windows will hang waiting for the window to respond to
- * synchronous system messages. At some point, we may want to consider
- * destroying the window if we leave the modal loop, but for now we'll
- * leave it around.
- */
+ /*
+ * If this is the first time that the notifier has been used from a modal
+ * loop, then create a communication window. Note that after this point,
+ * the application needs to service events in a timely fashion or Windows
+ * will hang waiting for the window to respond to synchronous system
+ * messages. At some point, we may want to consider destroying the window
+ * if we leave the modal loop, but for now we'll leave it around.
+ */
- if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
- tsdPtr->hwnd = CreateWindowW(classname, classname,
- WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(),
- NULL);
+ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
+ tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED,
+ 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
- /*
- * Send an initial message to the window to ensure that we wake up
- * the notifier once we get into the modal loop. This will force
- * the notifier to recompute the timeout value and schedule a timer
- * if one is needed.
- */
+ /*
+ * Send an initial message to the window to ensure that we wake up the
+ * notifier once we get into the modal loop. This will force the
+ * notifier to recompute the timeout value and schedule a timer if one
+ * is needed.
+ */
- Tcl_AlertNotifier(tsdPtr);
- }
+ Tcl_AlertNotifier(tsdPtr);
}
}
/*
*----------------------------------------------------------------------
*
+ * TclAsyncNotifier --
+ *
+ * This procedure is a no-op on Windows.
+ *
+ * Result:
+ * Always true.
+ *
+ * Side effetcs:
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+int
+TclAsyncNotifier(
+ TCL_UNUSED(int), /* Signal number. */
+ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
+ TCL_UNUSED(void *), /* Notifier data. */
+ TCL_UNUSED(int *), /* Flag to mark. */
+ TCL_UNUSED(int)) /* Value of mark. */
+{
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NotifierProc --
*
* This procedure is invoked by Windows to process events on the notifier
@@ -412,7 +422,30 @@ NotifierProc(
/*
*----------------------------------------------------------------------
*
- * Tcl_WaitForEvent --
+ * TclpNotifierData --
+ *
+ * This function returns a ClientData pointer to be associated
+ * with a Tcl_AsyncHandler.
+ *
+ * Results:
+ * On Windows, 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
@@ -429,103 +462,99 @@ NotifierProc(
*/
int
-Tcl_WaitForEvent(
+TclpWaitForEvent(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
- if (tclNotifierHooks.waitForEventProc) {
- return tclNotifierHooks.waitForEventProc(timePtr);
- } else {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- MSG msg;
- DWORD timeout, result;
- int status;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ MSG msg;
+ DWORD timeout, result;
+ int status;
+ /*
+ * Compute the timeout in milliseconds.
+ */
+
+ if (timePtr) {
/*
- * Compute the timeout in milliseconds.
+ * TIP #233 (Virtualized Time). Convert virtual domain delay to
+ * real-time.
*/
- if (timePtr) {
- /*
- * TIP #233 (Virtualized Time). Convert virtual domain delay to
- * real-time.
- */
+ Tcl_Time myTime;
- Tcl_Time myTime;
+ myTime.sec = timePtr->sec;
+ myTime.usec = timePtr->usec;
- myTime.sec = timePtr->sec;
- myTime.usec = timePtr->usec;
+ if (myTime.sec != 0 || myTime.usec != 0) {
+ TclScaleTime(&myTime);
+ }
- if (myTime.sec != 0 || myTime.usec != 0) {
- tclScaleTimeProcPtr(&myTime, tclTimeClientData);
- }
+ timeout = myTime.sec * 1000 + myTime.usec / 1000;
+ } else {
+ timeout = INFINITE;
+ }
- timeout = myTime.sec * 1000 + myTime.usec / 1000;
- } else {
- timeout = INFINITE;
- }
+ /*
+ * Check to see if there are any messages in the queue before waiting
+ * because MsgWaitForMultipleObjects will not wake up if there are events
+ * currently sitting in the queue.
+ */
+ if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
- * Check to see if there are any messages in the queue before waiting
- * because MsgWaitForMultipleObjects will not wake up if there are
- * events currently sitting in the queue.
+ * Wait for something to happen (a signal from another thread, a
+ * message, or timeout) or loop servicing asynchronous procedure calls
+ * queued to this thread.
*/
- if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
- /*
- * Wait for something to happen (a signal from another thread, a
- * message, or timeout) or loop servicing asynchronous procedure
- * calls queued to this thread.
- */
-
- again:
+ do {
result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout,
QS_ALLINPUT, MWMO_ALERTABLE);
- if (result == WAIT_IO_COMPLETION) {
- goto again;
- } else if (result == WAIT_FAILED) {
- status = -1;
- goto end;
- }
+ } while (result == WAIT_IO_COMPLETION);
+
+ if (result == WAIT_FAILED) {
+ status = -1;
+ goto end;
}
+ }
+
+ /*
+ * Check to see if there are any messages to process.
+ */
+ if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
- * Check to see if there are any messages to process.
+ * Retrieve and dispatch the first message.
*/
- if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
+ result = GetMessageW(&msg, NULL, 0, 0);
+ if (result == 0) {
+ /*
+ * We received a request to exit this thread (WM_QUIT), so
+ * propagate the quit message and start unwinding.
+ */
+
+ PostQuitMessage((int) msg.wParam);
+ status = -1;
+ } else if (result == (DWORD) -1) {
/*
- * Retrieve and dispatch the first message.
+ * We got an error from the system. I have no idea why this would
+ * happen, so we'll just unwind.
*/
- result = GetMessageW(&msg, NULL, 0, 0);
- if (result == 0) {
- /*
- * We received a request to exit this thread (WM_QUIT), so
- * propagate the quit message and start unwinding.
- */
-
- PostQuitMessage((int) msg.wParam);
- status = -1;
- } else if (result == (DWORD)-1) {
- /*
- * We got an error from the system. I have no idea why this
- * would happen, so we'll just unwind.
- */
-
- status = -1;
- } else {
- TranslateMessage(&msg);
- DispatchMessageW(&msg);
- status = 1;
- }
+ status = -1;
} else {
- status = 0;
+ TranslateMessage(&msg);
+ DispatchMessageW(&msg);
+ status = 1;
}
-
- end:
- ResetEvent(tsdPtr->event);
- return status;
+ } else {
+ status = 0;
}
+
+ end:
+ ResetEvent(tsdPtr->event);
+ return status;
}
/*
@@ -579,7 +608,7 @@ Tcl_Sleep(
* TIP #233: Scale delay from virtual to real-time.
*/
- tclScaleTimeProcPtr(&vdelay, tclTimeClientData);
+ TclScaleTime(&vdelay);
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
for (;;) {
@@ -594,7 +623,7 @@ Tcl_Sleep(
vdelay.sec = desired.sec - now.sec;
vdelay.usec = desired.usec - now.usec;
- tclScaleTimeProcPtr(&vdelay, tclTimeClientData);
+ TclScaleTime(&vdelay);
sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000;
}
}
diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c
new file mode 100644
index 0000000..3131286
--- /dev/null
+++ b/win/tclWinPanic.c
@@ -0,0 +1,88 @@
+/*
+ * tclWinPanic.c --
+ *
+ * Contains the Windows-specific command-line panic proc.
+ *
+ * Copyright © 2013 Jan Nijtmans.
+ * 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"
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ConsolePanic --
+ *
+ * Display a message. If a debugger is present, present it directly to
+ * the debugger, otherwise send it to stderr.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ConsolePanic(
+ const char *format, ...)
+{
+#define TCL_MAX_WARN_LEN 26000
+ va_list argList;
+ WCHAR msgString[TCL_MAX_WARN_LEN];
+ char buf[TCL_MAX_WARN_LEN * 3];
+ HANDLE handle = GetStdHandle(STD_ERROR_HANDLE);
+ DWORD dummy;
+
+ va_start(argList, format);
+ vsnprintf(buf+3, sizeof(buf)-3, format, argList);
+ buf[sizeof(buf)-1] = 0;
+ msgString[TCL_MAX_WARN_LEN-1] = '\0';
+ MultiByteToWideChar(CP_UTF8, 0, buf+3, -1, msgString, TCL_MAX_WARN_LEN);
+
+ /*
+ * Truncate MessageBox string if it is too long to not overflow the buffer.
+ */
+
+ if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
+ memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
+ }
+
+ if (IsDebuggerPresent()) {
+ OutputDebugStringW(msgString);
+ } else if (_isatty(2)) {
+ WriteConsoleW(handle, msgString, (DWORD)wcslen(msgString), &dummy, 0);
+ } else {
+ buf[0] = '\xEF'; buf[1] = '\xBB'; buf[2] = '\xBF'; /* UTF-8 bom */
+ WriteFile(handle, buf, (DWORD)strlen(buf), &dummy, 0);
+ WriteFile(handle, "\n", 1, &dummy, 0);
+ FlushFileBuffers(handle);
+ }
+# if defined(__GNUC__)
+ __builtin_trap();
+# elif defined(_WIN64)
+ __debugbreak();
+# elif defined(_MSC_VER)
+ _asm {int 3}
+# else
+ DebugBreak();
+# endif
+#if defined(_WIN32)
+ ExitProcess(1);
+#else
+ abort();
+#endif
+}
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 8b707fa..14767f9 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -4,7 +4,7 @@
* This file implements the Windows-specific exec pipeline functions, the
* "pipe" channel driver, and the "pid" Tcl command.
*
- * Copyright (c) 1996-1997 by 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.
@@ -104,7 +104,7 @@ typedef struct PipeInfo {
TclFile readFile; /* Output from pipe. */
TclFile writeFile; /* Input from pipe. */
TclFile errorFile; /* Error output from pipe. */
- int numPids; /* Number of processes attached to pipe. */
+ Tcl_Size numPids; /* Number of processes attached to pipe. */
Tcl_Pid *pidPtr; /* Pids of attached processes. */
Tcl_ThreadId threadId; /* Thread to which events should be reported.
* This value is used by the reader/writer
@@ -171,28 +171,28 @@ typedef struct {
static int ApplicationType(Tcl_Interp *interp,
const char *fileName, char *fullName);
-static void BuildCommandLine(const char *executable, int argc,
+static void BuildCommandLine(const char *executable, Tcl_Size argc,
const char **argv, Tcl_DString *linePtr);
static BOOL HasConsole(void);
-static int PipeBlockModeProc(ClientData instanceData, int mode);
-static void PipeCheckProc(ClientData clientData, int flags);
-static int PipeClose2Proc(ClientData instanceData,
+static int PipeBlockModeProc(void *instanceData, int mode);
+static void PipeCheckProc(void *clientData, int flags);
+static int PipeClose2Proc(void *instanceData,
Tcl_Interp *interp, int flags);
static int PipeEventProc(Tcl_Event *evPtr, int flags);
-static int PipeGetHandleProc(ClientData instanceData,
- int direction, ClientData *handlePtr);
+static int PipeGetHandleProc(void *instanceData,
+ int direction, void **handlePtr);
static void PipeInit(void);
-static int PipeInputProc(ClientData instanceData, char *buf,
+static int PipeInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
-static int PipeOutputProc(ClientData instanceData,
+static int PipeOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
static DWORD WINAPI PipeReaderThread(LPVOID arg);
-static void PipeSetupProc(ClientData clientData, int flags);
-static void PipeWatchProc(ClientData instanceData, int mask);
+static void PipeSetupProc(void *clientData, int flags);
+static void PipeWatchProc(void *instanceData, int mask);
static DWORD WINAPI PipeWriterThread(LPVOID arg);
static int TempFileName(WCHAR name[MAX_PATH]);
static int WaitForRead(PipeInfo *infoPtr, int blocking);
-static void PipeThreadActionProc(ClientData instanceData,
+static void PipeThreadActionProc(void *instanceData,
int action);
/*
@@ -310,7 +310,7 @@ TclpFinalizePipes(void)
void
PipeSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
@@ -363,7 +363,7 @@ PipeSetupProc(
static void
PipeCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
@@ -500,7 +500,7 @@ TclpMakeFile(
HANDLE handle;
if (Tcl_GetChannelHandle(channel, direction,
- (ClientData *) &handle) == TCL_OK) {
+ (void **) &handle) == TCL_OK) {
return TclWinMakeFile(handle);
} else {
return (TclFile) NULL;
@@ -549,7 +549,7 @@ TclpOpenFile(
accessMode = (GENERIC_READ | GENERIC_WRITE);
break;
default:
- TclWinConvertError(ERROR_INVALID_FUNCTION);
+ Tcl_WinConvertError(ERROR_INVALID_FUNCTION);
return NULL;
}
@@ -577,7 +577,8 @@ TclpOpenFile(
break;
}
- nativePath = (WCHAR *)Tcl_WinUtfToTChar(path, -1, &ds);
+ Tcl_DStringInit(&ds);
+ nativePath = Tcl_UtfToWCharDString(path, TCL_INDEX_NONE, &ds);
/*
* If the file is not being created, use the existing file attributes.
@@ -612,7 +613,7 @@ TclpOpenFile(
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
- TclWinConvertError(err);
+ Tcl_WinConvertError(err);
return NULL;
}
@@ -678,7 +679,7 @@ TclpCreateTempFile(
* Convert the contents from UTF to native encoding
*/
- native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
+ native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring);
toCopy = Tcl_DStringLength(&dstring);
for (p = native; toCopy > 0; p++, toCopy--) {
@@ -718,7 +719,7 @@ TclpCreateTempFile(
Tcl_DStringFree(&dstring);
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
CloseHandle(handle);
DeleteFileW(name);
return NULL;
@@ -783,7 +784,7 @@ TclpCreatePipe(
return 1;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return 0;
}
@@ -824,7 +825,7 @@ TclpCloseFile(
&& (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
if (filePtr->handle != NULL &&
CloseHandle(filePtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
ckfree(filePtr);
return -1;
}
@@ -850,7 +851,7 @@ TclpCloseFile(
* Results:
* Returns the process id for the child process. If the pid was not known
* by Tcl, either because the pid was not created by Tcl or the child
- * process has already been reaped, -1 is returned.
+ * process has already been reaped, TCL_INDEX_NONE is returned.
*
* Side effects:
* None.
@@ -858,7 +859,7 @@ TclpCloseFile(
*--------------------------------------------------------------------------
*/
-int
+Tcl_Size
TclpGetPid(
Tcl_Pid pid) /* The HANDLE of the child process. */
{
@@ -868,13 +869,13 @@ TclpGetPid(
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
- if (infoPtr->hProcess == (HANDLE) pid) {
+ if (infoPtr->dwProcessId == (DWORD)(size_t)pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
Tcl_MutexUnlock(&pipeMutex);
- return (unsigned long) -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -910,7 +911,7 @@ TclpCreateProcess(
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
- int argc, /* Number of arguments in following array. */
+ Tcl_Size argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings. argv[0] contains
* the name of the executable converted to
* native format (using the
@@ -940,7 +941,7 @@ TclpCreateProcess(
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
- char execPath[MAX_PATH * TCL_UTF_MAX];
+ char execPath[MAX_PATH * 3];
WinFile *filePtr;
PipeInit();
@@ -1025,7 +1026,7 @@ TclpCreateProcess(
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate input handle: %s",
Tcl_PosixError(interp)));
@@ -1054,7 +1055,7 @@ TclpCreateProcess(
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate output handle: %s",
Tcl_PosixError(interp)));
@@ -1074,7 +1075,7 @@ TclpCreateProcess(
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate error handle: %s",
Tcl_PosixError(interp)));
@@ -1094,40 +1095,23 @@ TclpCreateProcess(
* detached processes. The GUI window will still pop up to the foreground.
*/
- if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
- if (HasConsole()) {
+ if (HasConsole()) {
createFlags = 0;
- } else if (applType == APPL_DOS) {
- /*
- * Under NT, 16-bit DOS applications will not run unless they can
- * be attached to a console. If we are running without a console,
- * run the 16-bit program as an normal process inside of a hidden
- * console application, and then run that hidden console as a
- * detached process.
- */
+ } else if (applType == APPL_DOS) {
+ /*
+ * Under NT, 16-bit DOS applications will not run unless they can
+ * be attached to a console. If we are running without a console,
+ * run the 16-bit program as an normal process inside of a hidden
+ * console application, and then run that hidden console as a
+ * detached process.
+ */
- startInfo.wShowWindow = SW_HIDE;
- startInfo.dwFlags |= STARTF_USESHOWWINDOW;
- createFlags = CREATE_NEW_CONSOLE;
- TclDStringAppendLiteral(&cmdLine, "cmd.exe /c");
- } else {
- createFlags = DETACHED_PROCESS;
- }
+ startInfo.wShowWindow = SW_HIDE;
+ startInfo.dwFlags |= STARTF_USESHOWWINDOW;
+ createFlags = CREATE_NEW_CONSOLE;
+ TclDStringAppendLiteral(&cmdLine, "cmd.exe /c");
} else {
- if (HasConsole()) {
- createFlags = 0;
- } else {
- createFlags = DETACHED_PROCESS;
- }
-
- if (applType == APPL_DOS) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "DOS application process not supported on this platform",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP",
- NULL);
- goto end;
- }
+ createFlags = DETACHED_PROCESS;
}
/*
@@ -1153,7 +1137,7 @@ TclpCreateProcess(
if (CreateProcessW(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine),
NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
&procInfo) == 0) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
argv[0], Tcl_PosixError(interp)));
goto end;
@@ -1172,14 +1156,14 @@ TclpCreateProcess(
* will be created for each process but the previous instances may not be
* cleaned up. This results in a significant virtual memory loss each time
* the process is spawned. If there is a WaitForInputIdle() call between
- * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID
+ * CreateProcessW() and CloseHandle(), the problem does not occur." PSS ID
* Number: Q124121
*/
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
- *pidPtr = (Tcl_Pid) procInfo.hProcess;
+ *pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId;
if (*pidPtr != 0) {
TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
}
@@ -1294,20 +1278,21 @@ ApplicationType(
* Using the raw SearchPathW() function doesn't do quite what is necessary.
* If the name of the executable already contains a '.' character, it will
* not try appending the specified extension when searching (in other
- * words, SearchPathW will not find the program "a.b.exe" if the arguments
+ * words, SearchPath will not find the program "a.b.exe" if the arguments
* specified "a.b" and ".exe"). So, first look for the file as it is
* named. Then manually append the extensions, looking for a match.
*/
applType = APPL_NONE;
Tcl_DStringInit(&nameBuf);
- Tcl_DStringAppend(&nameBuf, originalName, -1);
+ Tcl_DStringAppend(&nameBuf, originalName, TCL_INDEX_NONE);
nameLen = Tcl_DStringLength(&nameBuf);
for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
Tcl_DStringSetLength(&nameBuf, nameLen);
- Tcl_DStringAppend(&nameBuf, extensions[i], -1);
- nativeName = (WCHAR *)Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf),
+ Tcl_DStringAppend(&nameBuf, extensions[i], TCL_INDEX_NONE);
+ Tcl_DStringInit(&ds);
+ nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf),
Tcl_DStringLength(&nameBuf), &ds);
found = SearchPathW(NULL, nativeName, NULL, MAX_PATH,
nativeFullPath, &rest);
@@ -1325,7 +1310,8 @@ ApplicationType(
if ((attr == 0xFFFFFFFF) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
- strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *)nativeFullPath, -1, &ds));
+ Tcl_DStringInit(&ds);
+ strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
@@ -1401,7 +1387,7 @@ ApplicationType(
Tcl_DStringFree(&nameBuf);
if (applType == APPL_NONE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
originalName, Tcl_PosixError(interp)));
return APPL_NONE;
@@ -1416,7 +1402,8 @@ ApplicationType(
*/
GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH);
- strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *)nativeFullPath, -1, &ds));
+ Tcl_DStringInit(&ds);
+ strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds));
Tcl_DStringFree(&ds);
}
return applType;
@@ -1428,7 +1415,7 @@ ApplicationType(
* BuildCommandLine --
*
* The command line arguments are stored in linePtr separated by spaces,
- * in a form that CreateProcess() understands. Special characters in
+ * in a form that CreateProcessW() understands. Special characters in
* individual arguments from argv[] must be quoted when being stored in
* cmdLine.
*
@@ -1549,13 +1536,14 @@ static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
- int argc, /* Number of arguments. */
+ Tcl_Size argc, /* Number of arguments. */
const char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
* command line (WCHAR). */
{
const char *arg, *start, *special, *bspos;
- int quote = 0, i;
+ int quote = 0;
+ Tcl_Size i;
Tcl_DString ds;
static const char specMetaChars[] = "&|^<>!()%";
/* Characters to enclose in quotes if unpaired
@@ -1641,7 +1629,7 @@ BuildCommandLine(
* Nothing to escape.
*/
- Tcl_DStringAppend(&ds, arg, -1);
+ Tcl_DStringAppend(&ds, arg, TCL_INDEX_NONE);
} else {
start = arg;
for (special = arg; *special != '\0'; ) {
@@ -1744,7 +1732,8 @@ BuildCommandLine(
}
}
Tcl_DStringFree(linePtr);
- Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
+ Tcl_DStringInit(linePtr);
+ Tcl_UtfToWCharDString(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
@@ -1771,7 +1760,7 @@ TclpCreateCommandChannel(
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
- int numPids, /* The number of pids in the pid array. */
+ Tcl_Size numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
@@ -1845,7 +1834,7 @@ TclpCreateCommandChannel(
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\x1A {}");
return infoPtr->channel;
}
@@ -1868,7 +1857,7 @@ Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result.*/
Tcl_Channel *rchan, /* Where to return the read side. */
Tcl_Channel *wchan, /* Where to return the write side. */
- int flags) /* Reserved for future use. */
+ TCL_UNUSED(int) /*flags*/) /* Reserved for future use. */
{
HANDLE readHandle, writeHandle;
SECURITY_ATTRIBUTES sec;
@@ -1878,16 +1867,16 @@ Tcl_CreatePipe(
sec.bInheritHandle = FALSE;
if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"pipe creation failed: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
- *rchan = Tcl_MakeFileChannel((ClientData) readHandle, TCL_READABLE);
+ *rchan = Tcl_MakeFileChannel((void *) readHandle, TCL_READABLE);
Tcl_RegisterChannel(interp, *rchan);
- *wchan = Tcl_MakeFileChannel((ClientData) writeHandle, TCL_WRITABLE);
+ *wchan = Tcl_MakeFileChannel((void *) writeHandle, TCL_WRITABLE);
Tcl_RegisterChannel(interp, *wchan);
return TCL_OK;
@@ -1918,7 +1907,7 @@ TclGetAndDetachPids(
PipeInfo *pipePtr;
const Tcl_ChannelType *chanTypePtr;
Tcl_Obj *pidsObj;
- int i;
+ Tcl_Size i;
/*
* Punt if the channel is not a command channel.
@@ -1962,7 +1951,7 @@ TclGetAndDetachPids(
static int
PipeBlockModeProc(
- ClientData instanceData, /* Instance data for channel. */
+ void *instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
@@ -2001,7 +1990,7 @@ PipeBlockModeProc(
static int
PipeClose2Proc(
- ClientData instanceData, /* Pointer to PipeInfo structure. */
+ void *instanceData, /* Pointer to PipeInfo structure. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
@@ -2124,7 +2113,7 @@ PipeClose2Proc(
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
- errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
+ errChan = Tcl_MakeFileChannel((void *)filePtr->handle,
TCL_READABLE);
ckfree(filePtr);
} else {
@@ -2171,7 +2160,7 @@ PipeClose2Proc(
static int
PipeInputProc(
- ClientData instanceData, /* Pipe state. */
+ void *instanceData, /* Pipe state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
@@ -2236,7 +2225,7 @@ PipeInputProc(
return bytesRead;
}
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
if (errno == EPIPE) {
infoPtr->readFlags |= PIPE_EOF;
return 0;
@@ -2265,7 +2254,7 @@ PipeInputProc(
static int
PipeOutputProc(
- ClientData instanceData, /* Pipe state. */
+ void *instanceData, /* Pipe state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
@@ -2295,7 +2284,7 @@ PipeOutputProc(
*/
if (infoPtr->writeError) {
- TclWinConvertError(infoPtr->writeError);
+ Tcl_WinConvertError(infoPtr->writeError);
infoPtr->writeError = 0;
goto error;
}
@@ -2330,7 +2319,7 @@ PipeOutputProc(
if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite,
&bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
goto error;
}
}
@@ -2447,7 +2436,7 @@ PipeEventProc(
static void
PipeWatchProc(
- ClientData instanceData, /* Pipe state. */
+ void *instanceData, /* Pipe state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
@@ -2509,21 +2498,21 @@ PipeWatchProc(
static int
PipeGetHandleProc(
- ClientData instanceData, /* The pipe state. */
+ void *instanceData, /* The pipe state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr) /* Where to store the handle. */
+ void **handlePtr) /* Where to store the handle. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr;
if (direction == TCL_READABLE && infoPtr->readFile) {
filePtr = (WinFile*) infoPtr->readFile;
- *handlePtr = (ClientData) filePtr->handle;
+ *handlePtr = (void *) filePtr->handle;
return TCL_OK;
}
if (direction == TCL_WRITABLE && infoPtr->writeFile) {
filePtr = (WinFile*) infoPtr->writeFile;
- *handlePtr = (ClientData) filePtr->handle;
+ *handlePtr = (void *) filePtr->handle;
return TCL_OK;
}
return TCL_ERROR;
@@ -2577,7 +2566,7 @@ Tcl_WaitPid(
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
- if (infoPtr->hProcess == (HANDLE) pid) {
+ if (infoPtr->dwProcessId == (DWORD) (size_t) pid) {
*prevPtrPtr = infoPtr->nextPtr;
break;
}
@@ -2754,7 +2743,7 @@ TclWinAddProcess(
int
Tcl_PidObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
@@ -2762,7 +2751,7 @@ Tcl_PidObjCmd(
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
- int i;
+ Tcl_Size i;
Tcl_Obj *resultPtr;
if (objc > 2) {
@@ -2862,7 +2851,7 @@ WaitForRead(
if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0,
(LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
/*
* Check to see if the peek failed because of EOF.
@@ -3148,7 +3137,7 @@ PipeWriterThread(
static void
PipeThreadActionProc(
- ClientData instanceData,
+ void *instanceData,
int action)
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
@@ -3200,16 +3189,17 @@ PipeThreadActionProc(
Tcl_Channel
TclpOpenTemporaryFile(
- Tcl_Obj *dirObj,
+ TCL_UNUSED(Tcl_Obj *) /*dirObj*/,
Tcl_Obj *basenameObj,
- Tcl_Obj *extensionObj,
+ TCL_UNUSED(Tcl_Obj *) /*extensionObj*/,
Tcl_Obj *resultingNameObj)
{
WCHAR name[MAX_PATH];
char *namePtr;
HANDLE handle;
DWORD flags = FILE_ATTRIBUTE_TEMPORARY;
- int length, counter, counter2;
+ Tcl_Size length;
+ int counter, counter2;
Tcl_DString buf;
if (!resultingNameObj) {
@@ -3223,9 +3213,10 @@ TclpOpenTemporaryFile(
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
- const char *string = Tcl_GetString(basenameObj);
+ const char *string = TclGetStringFromObj(basenameObj, &length);
- Tcl_WinUtfToTChar(string, basenameObj->length, &buf);
+ Tcl_DStringInit(&buf);
+ Tcl_UtfToWCharDString(string, length, &buf);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf));
namePtr += Tcl_DStringLength(&buf);
Tcl_DStringFree(&buf);
@@ -3245,7 +3236,8 @@ TclpOpenTemporaryFile(
snprintf(number, sizeof(number), "%d.TMP", counter);
counter = (unsigned short) (counter + 1);
- Tcl_WinUtfToTChar(number, strlen(number), &buf);
+ Tcl_DStringInit(&buf);
+ Tcl_UtfToWCharDString(number, strlen(number), &buf);
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
@@ -3266,11 +3258,11 @@ TclpOpenTemporaryFile(
TclDecrRefCount(tmpObj);
}
- return Tcl_MakeFileChannel((ClientData) handle,
+ return Tcl_MakeFileChannel((void *) handle,
TCL_READABLE|TCL_WRITABLE);
gotError:
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return NULL;
}
@@ -3290,7 +3282,7 @@ TclpOpenTemporaryFile(
TclPipeThreadInfo *
TclPipeThreadCreateTI(
TclPipeThreadInfo **pipeTIPtr,
- ClientData clientData,
+ void *clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
@@ -3584,9 +3576,7 @@ TclPipeThreadStop(
* Cancel all sync-IO of this thread (may be blocked there).
*/
- if (tclWinProcs.cancelSynchronousIo) {
- tclWinProcs.cancelSynchronousIo(hThread);
- }
+ CancelSynchronousIo(hThread);
/*
* Wait at most 20 milliseconds for the reader thread to close
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 5e7f9c3..d7d60a4 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -18,18 +18,22 @@
/* See [Bug 3354324]: file mtime sets wrong time */
# define __MINGW_USE_VC2005_COMPAT
#endif
+#if defined(_MSC_VER) && defined(_WIN64) && !defined(STATIC_BUILD) \
+ && !defined(MP_32BIT) && !defined(MP_64BIT)
+# define MP_64BIT
+#endif
/*
* We must specify the lower version we intend to support.
*
- * WINVER = 0x0501 means Windows XP and above
+ * WINVER = 0x0601 means Windows 7 and above
*/
#ifndef WINVER
-# define WINVER 0x0501
+# define WINVER 0x0601
#endif
#ifndef _WIN32_WINNT
-# define _WIN32_WINNT 0x0501
+# define _WIN32_WINNT 0x0601
#endif
#define WIN32_LEAN_AND_MEAN
@@ -54,15 +58,6 @@ typedef DWORD_PTR * PDWORD_PTR;
# include <wspiapi.h>
#endif
-#ifdef CHECK_UNICODE_CALLS
-# define _UNICODE
-# define UNICODE
-# define __TCHAR_DEFINED
- typedef float *_TCHAR;
-# define _TCHAR_DEFINED
- typedef float *TCHAR;
-#endif /* CHECK_UNICODE_CALLS */
-
/*
* Pull in the typedef of TCHAR for windows.
*/
@@ -97,6 +92,11 @@ typedef DWORD_PTR * PDWORD_PTR;
# include <inttypes.h>
#endif
#include <limits.h>
+#ifdef HAVE_STDINT_H
+# include <stdint.h>
+#else
+# include "../compat/stdint.h"
+#endif
#ifndef __GNUC__
# define strncasecmp _strnicmp
@@ -111,11 +111,7 @@ typedef DWORD_PTR * PDWORD_PTR;
#ifndef __MWERKS__
#include <sys/stat.h>
#include <sys/timeb.h>
-# ifdef __BORLANDC__
-# include <utime.h>
-# else
-# include <sys/utime.h>
-# endif /* __BORLANDC__ */
+#include <sys/utime.h>
#endif /* __MWERKS__ */
/*
@@ -454,46 +450,24 @@ typedef DWORD_PTR * PDWORD_PTR;
#if defined(_MSC_VER) || defined(__MSVCRT__)
# define environ _environ
-# if defined(_MSC_VER) && (_MSC_VER < 1600)
-# define hypot _hypot
-# endif
# define exception _exception
# undef EDEADLOCK
-# if defined(_MSC_VER) && (_MSC_VER >= 1700)
+# if defined(_MSC_VER)
# define timezone _timezone
# endif
#endif /* _MSC_VER || __MSVCRT__ */
-/*
- * Borland's timezone and environ functions.
- */
-
-#ifdef __BORLANDC__
-# define timezone _timezone
-# define environ _environ
-#endif /* __BORLANDC__ */
-
-#ifdef __WATCOMC__
-# if !defined(__CHAR_SIGNED__)
-# error "You must use the -j switch to ensure char is signed."
-# endif
-#endif
-
-
-/*
- * MSVC 8.0 started to mark many standard C library functions depreciated
- * including the *printf family and others. Tell it to shut up.
- * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
- */
#if defined(_MSC_VER)
# pragma warning(disable:4090) /* see: https://developercommunity.visualstudio.com/t/c-compiler-incorrect-propagation-of-const-qualifie/390711 */
# pragma warning(disable:4146)
# pragma warning(disable:4244)
-# if _MSC_VER >= 1400
-# pragma warning(disable:4267)
-# pragma warning(disable:4996)
-# endif
+#if !defined(_WIN64)
+# pragma warning(disable:4305)
#endif
+# pragma warning(disable:4267)
+# pragma warning(disable:4996)
+#endif
+
/*
*---------------------------------------------------------------------------
* The following macros and declarations represent the interface between
@@ -559,7 +533,7 @@ typedef DWORD_PTR * PDWORD_PTR;
* address platform-specific issues.
*/
-#define TclpReleaseFile(file) ckfree((char *) file)
+#define TclpReleaseFile(file) ckfree(file)
/*
* The following macros and declarations wrap the C runtime library
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index d54ead2..1ccb105 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -124,7 +124,7 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj, REGSAM mode);
-#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
+#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)
@@ -132,32 +132,20 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
+#define Tcl_Size int
+#define TCL_INDEX_NONE -1
#endif
-static unsigned char *
-getByteArrayFromObj(
- Tcl_Obj *objPtr,
- size_t *lengthPtr
-) {
- int length;
-
- unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
-#if TCL_MAJOR_VERSION > 8
- if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
- /* 64-bit and TIP #494 situation: */
- *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
- } else
-#endif
- /* 32-bit or without TIP #494 */
- *lengthPtr = (size_t) (unsigned) length;
- return result;
-}
-
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
+#if TCL_MAJOR_VERSION < 9
+/* With those additional entries, "load registry13.dll" works without 3th argument */
+DLLEXPORT int Tclregistry_Init(Tcl_Interp *interp);
+DLLEXPORT int Tclregistry_Unload(Tcl_Interp *interp, int flags);
+#endif
#ifdef __cplusplus
}
#endif
@@ -191,8 +179,16 @@ Registry_Init(
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
- return Tcl_PkgProvideEx(interp, "registry", "1.3.5", NULL);
+ return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL);
+}
+#if TCL_MAJOR_VERSION < 9
+int
+Tclregistry_Init(
+ Tcl_Interp *interp)
+{
+ return Registry_Init(interp);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -223,9 +219,9 @@ Registry_Unload(
* Unregister the registry package. There is no Tcl_PkgForget()
*/
- objv[0] = Tcl_NewStringObj("package", -1);
- objv[1] = Tcl_NewStringObj("forget", -1);
- objv[2] = Tcl_NewStringObj("registry", -1);
+ objv[0] = Tcl_NewStringObj("package", TCL_INDEX_NONE);
+ objv[1] = Tcl_NewStringObj("forget", TCL_INDEX_NONE);
+ objv[2] = Tcl_NewStringObj("registry", TCL_INDEX_NONE);
Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
/*
@@ -239,6 +235,15 @@ Registry_Unload(
return TCL_OK;
}
+#if TCL_MAJOR_VERSION < 9
+int
+Tclregistry_Unload(
+ Tcl_Interp *interp,
+ int flags)
+{
+ return Registry_Unload(interp, flags);
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -438,13 +443,14 @@ DeleteKey(
DWORD result;
Tcl_DString buf;
REGSAM saveMode = mode;
+ Tcl_Size len;
/*
* Find the parent of the key being deleted and open it.
*/
- keyName = Tcl_GetString(keyNameObj);
- buffer = (char *)Tcl_Alloc(keyNameObj->length + 1);
+ keyName = Tcl_GetStringFromObj(keyNameObj, &len);
+ buffer = (char *)Tcl_Alloc(len + 1);
strcpy(buffer, keyName);
if (ParseKeyName(interp, buffer, &hostName, &rootKey,
@@ -455,7 +461,7 @@ DeleteKey(
if (*keyName == '\0') {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("bad key: cannot delete root keys", -1));
+ Tcl_NewStringObj("bad key: cannot delete root keys", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL);
Tcl_Free(buffer);
return TCL_ERROR;
@@ -477,7 +483,7 @@ DeleteKey(
return TCL_OK;
}
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("unable to delete key: ", -1));
+ Tcl_NewStringObj("unable to delete key: ", TCL_INDEX_NONE));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -487,13 +493,13 @@ DeleteKey(
*/
Tcl_DStringInit(&buf);
- nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf);
+ nativeTail = Tcl_UtfToWCharDString(tail, TCL_INDEX_NONE, &buf);
result = RecursiveDeleteKey(subkey, nativeTail, saveMode);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("unable to delete key: ", -1));
+ Tcl_NewStringObj("unable to delete key: ", TCL_INDEX_NONE));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -532,6 +538,7 @@ DeleteValue(
char *valueName;
DWORD result;
Tcl_DString ds;
+ Tcl_Size len;
/*
* Attempt to open the key for deletion.
@@ -542,9 +549,9 @@ DeleteValue(
return TCL_ERROR;
}
- valueName = Tcl_GetString(valueNameObj);
+ valueName = Tcl_GetStringFromObj(valueNameObj, &len);
Tcl_DStringInit(&ds);
- Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
+ Tcl_UtfToWCharDString(valueName, len, &ds);
result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
@@ -685,6 +692,7 @@ GetType(
Tcl_DString ds;
const char *valueName;
const WCHAR *nativeValue;
+ Tcl_Size len;
/*
* Attempt to open the key for reading.
@@ -699,9 +707,9 @@ GetType(
* Get the type of the value.
*/
- valueName = Tcl_GetString(valueNameObj);
+ valueName = Tcl_GetStringFromObj(valueNameObj, &len);
Tcl_DStringInit(&ds);
- nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
+ nativeValue = Tcl_UtfToWCharDString(valueName, len, &ds);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
@@ -723,7 +731,7 @@ GetType(
if (type > lastType) {
Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
} else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], TCL_INDEX_NONE));
}
return TCL_OK;
}
@@ -757,6 +765,7 @@ GetValue(
const WCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
+ Tcl_Size len;
/*
* Attempt to open the key for reading.
@@ -781,9 +790,9 @@ GetValue(
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1;
- valueName = Tcl_GetString(valueNameObj);
+ valueName = Tcl_GetStringFromObj(valueNameObj, &len);
Tcl_DStringInit(&buf);
- nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf);
+ nativeValue = Tcl_UtfToWCharDString(valueName, len, &buf);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
@@ -795,7 +804,7 @@ GetValue(
*/
length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR));
- Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR));
+ Tcl_DStringSetLength(&data, length * sizeof(WCHAR));
result = RegQueryValueExW(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
@@ -856,7 +865,7 @@ GetValue(
*/
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
- (BYTE *) Tcl_DStringValue(&data), (int) length));
+ (BYTE *) Tcl_DStringValue(&data), length));
}
Tcl_DStringFree(&data);
return result;
@@ -905,7 +914,7 @@ GetValueNames(
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
- Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
+ Tcl_DStringSetLength(&buffer, MAX_KEY_LENGTH * sizeof(WCHAR));
index = 0;
result = TCL_OK;
@@ -975,9 +984,10 @@ OpenKey(
char *keyName, *buffer, *hostName;
HKEY rootKey;
DWORD result;
+ Tcl_Size len;
- keyName = Tcl_GetString(keyNameObj);
- buffer = (char *)Tcl_Alloc(keyNameObj->length + 1);
+ keyName = Tcl_GetStringFromObj(keyNameObj, &len);
+ buffer = (char *)Tcl_Alloc(len + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
@@ -985,7 +995,7 @@ OpenKey(
result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("unable to open key: ", -1));
+ Tcl_NewStringObj("unable to open key: ", TCL_INDEX_NONE));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -1033,7 +1043,7 @@ OpenSubKey(
if (hostName) {
Tcl_DStringInit(&buf);
- hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf);
+ hostName = (char *) Tcl_UtfToWCharDString(hostName, TCL_INDEX_NONE, &buf);
result = RegConnectRegistryW((WCHAR *)hostName, rootKey,
&rootKey);
Tcl_DStringFree(&buf);
@@ -1049,7 +1059,7 @@ OpenSubKey(
if (keyName) {
Tcl_DStringInit(&buf);
- keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf);
+ keyName = (char *) Tcl_UtfToWCharDString(keyName, TCL_INDEX_NONE, &buf);
}
if (flags & REG_CREATE) {
DWORD create;
@@ -1153,7 +1163,7 @@ ParseKeyName(
* Look for a matching root name.
*/
- rootObj = Tcl_NewStringObj(rootName, -1);
+ rootObj = Tcl_NewStringObj(rootName, TCL_INDEX_NONE);
result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",
TCL_EXACT, &index);
Tcl_DecrRefCount(rootObj);
@@ -1211,7 +1221,7 @@ RecursiveDeleteKey(
}
Tcl_DStringInit(&subkey);
- Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
+ Tcl_DStringSetLength(&subkey, MAX_KEY_LENGTH * sizeof(WCHAR));
mode = saveMode;
while (result == ERROR_SUCCESS) {
@@ -1285,6 +1295,7 @@ SetValue(
HKEY key;
const char *valueName;
Tcl_DString nameBuf;
+ Tcl_Size len;
if (typeObj == NULL) {
type = REG_SZ;
@@ -1300,9 +1311,9 @@ SetValue(
return TCL_ERROR;
}
- valueName = Tcl_GetString(valueNameObj);
+ valueName = Tcl_GetStringFromObj(valueNameObj, &len);
Tcl_DStringInit(&nameBuf);
- valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf);
+ valueName = (char *) Tcl_UtfToWCharDString(valueName, len, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
@@ -1318,7 +1329,7 @@ SetValue(
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
- int objc, i;
+ Tcl_Size objc, i;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
@@ -1335,9 +1346,9 @@ SetValue(
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
- const char *bytes = Tcl_GetString(objv[i]);
+ const char *bytes = Tcl_GetStringFromObj(objv[i], &len);
- Tcl_DStringAppend(&data, bytes, objv[i]->length);
+ Tcl_DStringAppend(&data, bytes, len);
/*
* Add a null character to separate this value from the next.
@@ -1356,10 +1367,10 @@ SetValue(
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
- const char *data = Tcl_GetString(dataObj);
+ const char *data = Tcl_GetStringFromObj(dataObj, &len);
Tcl_DStringInit(&buf);
- data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf);
+ data = (char *) Tcl_UtfToWCharDString(data, len, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
@@ -1372,13 +1383,13 @@ SetValue(
Tcl_DStringFree(&buf);
} else {
BYTE *data;
- size_t bytelength;
+ Tcl_Size bytelength;
/*
* Store binary data in the registry.
*/
- data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength);
+ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) bytelength);
}
@@ -1388,7 +1399,7 @@ SetValue(
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("unable to set value: ", -1));
+ Tcl_NewStringObj("unable to set value: ", TCL_INDEX_NONE));
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -1421,15 +1432,14 @@ BroadcastValue(
LRESULT result;
DWORD_PTR sendResult;
int timeout = 3000;
- size_t len;
+ Tcl_Size len;
const char *str;
Tcl_Obj *objPtr;
WCHAR *wstr;
Tcl_DString ds;
if (objc == 3) {
- str = Tcl_GetString(objv[1]);
- len = objv[1]->length;
+ str = Tcl_GetStringFromObj(objv[1], &len);
if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) {
return TCL_BREAK;
}
@@ -1438,9 +1448,9 @@ BroadcastValue(
}
}
- str = Tcl_GetString(objv[0]);
+ str = Tcl_GetStringFromObj(objv[0], &len);
Tcl_DStringInit(&ds);
- wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds);
+ wstr = Tcl_UtfToWCharDString(str, len, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 155312b..6ab305c 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -4,7 +4,7 @@
* This file implements the Windows-specific serial port functions, and
* the "serial" channel driver.
*
- * Copyright (c) 1999 by Scriptics Corp.
+ * Copyright © 1999 Scriptics Corp.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -44,6 +44,15 @@ TCL_DECLARE_MUTEX(serialMutex)
#define SERIAL_ERROR (1<<4)
/*
+ * Bit masks used for noting whether to drain or discard output on close. They
+ * are disjoint from each other; at most one may be set at a time.
+ */
+
+#define SERIAL_CLOSE_DRAIN (1<<6) /* Drain all output on close. */
+#define SERIAL_CLOSE_DISCARD (1<<7) /* Discard all output on close. */
+#define SERIAL_CLOSE_MASK (3<<6) /* Both two bits above. */
+
+/*
* Default time to block between checking status on the serial port.
*/
@@ -115,7 +124,7 @@ typedef struct SerialInfo {
* [fconfigure -queue] */
} SerialInfo;
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* The following pointer refers to the head of the list of serials that
* are being watched for file events.
@@ -131,7 +140,7 @@ static Tcl_ThreadDataKey dataKey;
* events are generated.
*/
-typedef struct SerialEvent {
+typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
SerialInfo *infoPtr; /* Pointer to serial info structure. Note that
@@ -159,8 +168,6 @@ static COMMTIMEOUTS no_timeout = {
static int SerialBlockProc(ClientData instanceData, int mode);
static void SerialCheckProc(ClientData clientData, int flags);
static int SerialCloseProc(ClientData instanceData,
- Tcl_Interp *interp);
-static int SerialClose2Proc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int SerialEventProc(Tcl_Event *evPtr, int flags);
static void SerialExitHandler(ClientData clientData);
@@ -197,7 +204,7 @@ static int SerialBlockingWrite(SerialInfo *infoPtr, LPVOID buf,
static const Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- SerialCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
SerialInputProc, /* Input proc. */
SerialOutputProc, /* Output proc. */
NULL, /* Seek proc. */
@@ -205,7 +212,7 @@ static const Tcl_ChannelType serialChannelType = {
SerialGetOptionProc, /* Get option proc. */
SerialWatchProc, /* Set up notifier to watch the channel. */
SerialGetHandleProc, /* Get an OS handle from channel. */
- SerialClose2Proc, /* close2proc. */
+ SerialCloseProc, /* close2proc. */
SerialBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
@@ -278,7 +285,7 @@ SerialInit(void)
static void
SerialExitHandler(
- ClientData clientData) /* Old window proc */
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
SerialInfo *infoPtr;
@@ -316,7 +323,7 @@ SerialExitHandler(
static void
ProcExitHandler(
- ClientData clientData) /* Old window proc */
+ TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&serialMutex);
initialized = 0;
@@ -393,9 +400,13 @@ SerialGetMilliseconds(void)
*----------------------------------------------------------------------
*/
+#ifdef __cplusplus
+#define min(a, b) (((a) < (b)) ? (a) : (b))
+#endif
+
void
SerialSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
@@ -450,7 +461,7 @@ SerialSetupProc(
static void
SerialCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
@@ -574,7 +585,7 @@ SerialBlockProc(
/*
*----------------------------------------------------------------------
*
- * SerialCloseProc/SerialClose2Proc --
+ * SerialCloseProc --
*
* Closes a serial based IO channel.
*
@@ -590,14 +601,18 @@ SerialBlockProc(
static int
SerialCloseProc(
ClientData instanceData, /* Pointer to SerialInfo structure. */
- Tcl_Interp *interp) /* For error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
{
SerialInfo *serialPtr = (SerialInfo *) instanceData;
- int errorCode, result = 0;
+ int errorCode = 0, result = 0;
SerialInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- errorCode = 0;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
@@ -606,7 +621,6 @@ SerialCloseProc(
serialPtr->validMask &= ~TCL_READABLE;
if (serialPtr->writeThread) {
-
TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread);
CloseHandle(serialPtr->osWrite.hEvent);
@@ -631,7 +645,7 @@ SerialCloseProc(
&& (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) {
if (CloseHandle(serialPtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
errorCode = errno;
}
}
@@ -666,18 +680,6 @@ SerialCloseProc(
}
return errorCode;
}
-
-static int
-SerialClose2Proc(
- ClientData instanceData, /* Pointer to SerialInfo structure. */
- Tcl_Interp *interp, /* For error reporting. */
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return SerialCloseProc(instanceData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -926,7 +928,7 @@ SerialInputProc(
if (SerialBlockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
&infoPtr->osRead) == FALSE) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
*errorCode = errno;
return -1;
}
@@ -1008,7 +1010,7 @@ SerialOutputProc(
*/
if (infoPtr->writeError) {
- TclWinConvertError(infoPtr->writeError);
+ Tcl_WinConvertError(infoPtr->writeError);
infoPtr->writeError = 0;
goto error1;
}
@@ -1067,7 +1069,7 @@ SerialOutputProc(
return (int) bytesWritten;
writeError:
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
error:
/*
@@ -1248,7 +1250,7 @@ SerialWatchProc(
static int
SerialGetHandleProc(
ClientData instanceData, /* The serial state. */
- int direction, /* TCL_READABLE or TCL_WRITABLE */
+ TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
@@ -1292,7 +1294,7 @@ SerialWriterThread(
/* exit */
break;
}
- infoPtr = (SerialInfo *)pipeTI->clientData;
+ infoPtr = (SerialInfo *) pipeTI->clientData;
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
@@ -1356,7 +1358,25 @@ SerialWriterThread(
Tcl_MutexUnlock(&serialMutex);
}
- /* Worker exit, so inform the main thread or free TI-structure (if owned) */
+ /*
+ * We're about to close, so do any drain or discard required.
+ */
+
+ if (infoPtr) {
+ switch (infoPtr->flags & SERIAL_CLOSE_MASK) {
+ case SERIAL_CLOSE_DRAIN:
+ FlushFileBuffers(infoPtr->handle);
+ break;
+ case SERIAL_CLOSE_DISCARD:
+ PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
+ break;
+ }
+ }
+
+ /*
+ * Worker exit, so inform the main thread or free TI-structure (if owned).
+ */
+
TclPipeThreadExit(&pipeTI);
return 0;
@@ -1391,7 +1411,7 @@ TclWinSerialOpen(
* If an open channel is specified, close it
*/
- if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) {
+ if (handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) {
return INVALID_HANDLE_VALUE;
}
@@ -1438,7 +1458,7 @@ TclWinOpenSerialChannel(
infoPtr = (SerialInfo *)ckalloc(sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
- infoPtr->validMask = permissions;
+ infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE);
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
infoPtr->readable = 0;
@@ -1494,7 +1514,7 @@ TclWinOpenSerialChannel(
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\x1A {}");
return infoPtr->channel;
}
@@ -1624,6 +1644,32 @@ SerialSetOptionProc(
vlen = strlen(value);
/*
+ * Option -closemode drain|discard|default
+ */
+
+ if ((len > 2) && (strncmp(optionName, "-closemode", len) == 0)) {
+ if (Tcl_UtfNcasecmp(value, "DEFAULT", vlen) == 0) {
+ infoPtr->flags &= ~SERIAL_CLOSE_MASK;
+ } else if (Tcl_UtfNcasecmp(value, "DRAIN", vlen) == 0) {
+ infoPtr->flags &= ~SERIAL_CLOSE_MASK;
+ infoPtr->flags |= SERIAL_CLOSE_DRAIN;
+ } else if (Tcl_UtfNcasecmp(value, "DISCARD", vlen) == 0) {
+ infoPtr->flags &= ~SERIAL_CLOSE_MASK;
+ infoPtr->flags |= SERIAL_CLOSE_DISCARD;
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad mode \"%s\" for -closemode: must be"
+ " default, discard, or drain", value));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+ "VALUE", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
* Option -mode baud,parity,databits,stopbits
*/
@@ -1631,7 +1677,8 @@ SerialSetOptionProc(
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
- native = (const WCHAR *)Tcl_WinUtfToTChar(value, -1, &ds);
+ Tcl_DStringInit(&ds);
+ native = Tcl_UtfToWCharDString(value, TCL_INDEX_NONE, &ds);
result = BuildCommDCBW(native, &dcb);
Tcl_DStringFree(&ds);
@@ -1732,7 +1779,7 @@ SerialSetOptionProc(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
- " two elements with each a single character", -1));
+ " two elements with each a single 8-bit character", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
ckfree(argv);
@@ -1752,16 +1799,16 @@ SerialSetOptionProc(
dcb.XonChar = argv[0][0];
dcb.XoffChar = argv[1][0];
if (argv[0][0] & 0x80 || argv[1][0] & 0x80) {
- int character;
+ Tcl_UniChar character = 0;
int charLen;
- charLen = TclUtfToUCS4(argv[0], &character);
- if ((character & ~0xFF) || argv[0][charLen]) {
+ charLen = Tcl_UtfToUniChar(argv[0], &character);
+ if ((character > 0xFF) || argv[0][charLen]) {
goto badXchar;
}
dcb.XonChar = (char) character;
- charLen = TclUtfToUCS4(argv[1], &character);
- if ((character & ~0xFF) || argv[1][charLen]) {
+ charLen = Tcl_UtfToUniChar(argv[1], &character);
+ if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
dcb.XoffChar = (char) character;
@@ -1805,7 +1852,7 @@ SerialSetOptionProc(
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't set DTR signal", -1));
+ "can't set DTR signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
@@ -1817,7 +1864,7 @@ SerialSetOptionProc(
(DWORD) (flag ? SETRTS : CLRRTS))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't set RTS signal", -1));
+ "can't set RTS signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
@@ -1829,7 +1876,7 @@ SerialSetOptionProc(
(DWORD) (flag ? SETBREAK : CLRBREAK))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't set BREAK signal", -1));
+ "can't set BREAK signal", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
@@ -1863,7 +1910,7 @@ SerialSetOptionProc(
* -sysbuffer 4096 or -sysbuffer {64536 4096}
*/
- size_t inSize = (size_t) -1, outSize = (size_t) -1;
+ int inSize = -1, outSize = -1;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
@@ -1889,7 +1936,7 @@ SerialSetOptionProc(
if (!SetupComm(infoPtr->handle, inSize, outSize)) {
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't setup comm buffers: %s",
Tcl_PosixError(interp)));
@@ -1940,7 +1987,7 @@ SerialSetOptionProc(
tout.ReadTotalTimeoutConstant = msec;
if (!SetCommTimeouts(infoPtr->handle, &tout)) {
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't set comm timeouts: %s",
Tcl_PosixError(interp)));
@@ -1952,11 +1999,12 @@ SerialSetOptionProc(
}
return Tcl_BadChannelOption(interp, optionName,
- "mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
+ "closemode mode handshake pollinterval sysbuffer timeout "
+ "ttycontrol xchar");
getStateFailed:
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
@@ -1964,7 +2012,7 @@ SerialSetOptionProc(
setStateFailed:
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't set comm state: %s", Tcl_PosixError(interp)));
}
@@ -2013,6 +2061,27 @@ SerialGetOptionProc(
}
/*
+ * Get option -closemode
+ */
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-closemode");
+ }
+ if (len==0 || (len>1 && strncmp(optionName, "-closemode", len)==0)) {
+ switch (infoPtr->flags & SERIAL_CLOSE_MASK) {
+ case SERIAL_CLOSE_DRAIN:
+ Tcl_DStringAppendElement(dsPtr, "drain");
+ break;
+ case SERIAL_CLOSE_DISCARD:
+ Tcl_DStringAppendElement(dsPtr, "discard");
+ break;
+ default:
+ Tcl_DStringAppendElement(dsPtr, "default");
+ break;
+ }
+ }
+
+ /*
* Get option -mode
*/
@@ -2026,7 +2095,7 @@ SerialGetOptionProc(
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
@@ -2096,16 +2165,15 @@ SerialGetOptionProc(
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
- buf[1] = '\0';
- buf[0] = dcb.XonChar;
+ buf[Tcl_UniCharToUtf(UCHAR(dcb.XonChar), buf)] = '\0';
Tcl_DStringAppendElement(dsPtr, buf);
- buf[0] = dcb.XoffChar;
+ buf[Tcl_UniCharToUtf(UCHAR(dcb.XoffChar), buf)] = '\0';
Tcl_DStringAppendElement(dsPtr, buf);
}
if (len == 0) {
@@ -2175,7 +2243,7 @@ SerialGetOptionProc(
if (!GetCommModemStatus(infoPtr->handle, &status)) {
if (interp != NULL) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get tty status: %s", Tcl_PosixError(interp)));
}
@@ -2189,7 +2257,8 @@ SerialGetOptionProc(
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval lasterror queue sysbuffer ttystatus xchar");
+ "closemode mode pollinterval lasterror queue sysbuffer ttystatus "
+ "xchar");
}
/*
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index abe8321..7dd5b41 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -3,7 +3,7 @@
*
* This file contains Windows-specific socket related code.
*
- * 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.
@@ -55,22 +55,6 @@
#endif
/*
- * Support for control over sockets' KEEPALIVE and NODELAY behavior is
- * currently disabled.
- */
-
-#undef TCL_FEATURE_KEEPALIVE_NAGLE
-
-/*
- * Make sure to remove the redirection defines set in tclWinPort.h that is in
- * use in other sections of the core, except for us.
- */
-
-#undef getservbyname
-#undef getsockopt
-#undef setsockopt
-
-/*
* Helper macros to make parts of this file clearer. The macros do exactly
* what they say on the tin. :-) They also only ever refer to their arguments
* once, and so can be used without regard to side effects.
@@ -134,9 +118,9 @@ typedef struct TcpFdList {
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
- struct TcpFdList *sockets; /* Windows SOCKET handle. */
int flags; /* Bit field comprised of the flags described
* below. */
+ struct TcpFdList *sockets; /* Windows SOCKET handle. */
int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE,
* FD_CLOSE, FD_ACCEPT and FD_CONNECT that
* indicate which events are interesting. */
@@ -193,6 +177,10 @@ struct TcpState {
* still pending */
#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */
+#define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not
+ * automatically continue connection
+ * process */
+
/*
* The following structure is what is added to the Tcl event queue when a
* socket event occurs.
@@ -246,7 +234,6 @@ static TcpState * NewSocketInfo(SOCKET socket);
static void SocketExitHandler(void *clientData);
static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam,
LPARAM lParam);
-static int SocketsEnabled(void);
static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);
static int WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static int WaitForSocketEvent(TcpState *statePtr, int events,
@@ -278,7 +265,11 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc;
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
+#ifndef TCL_NO_DEPRECATED
TcpCloseProc, /* Close proc. */
+#else
+ TCL_CLOSE2PROC, /* Close proc. */
+#endif
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
@@ -358,39 +349,38 @@ printaddrinfolist(
void
InitializeHostName(
char **valuePtr,
- int *lengthPtr,
+ TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
DWORD length = sizeof(wbuf)/sizeof(WCHAR);
Tcl_DString ds;
+ Tcl_DStringInit(&ds);
if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
- Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *)wbuf, -1, &ds));
+ Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds));
} else {
- Tcl_DStringInit(&ds);
- if (TclpHasSockets(NULL) == TCL_OK) {
- /*
- * The buffer size of 256 is recommended by the MSDN page that
- * documents gethostname() as being always adequate.
- */
+ TclInitSockets();
+ /*
+ * The buffer size of 256 is recommended by the MSDN page that
+ * documents gethostname() as being always adequate.
+ */
- Tcl_DString inDs;
+ Tcl_DString inDs;
- Tcl_DStringInit(&inDs);
- Tcl_DStringSetLength(&inDs, 256);
- if (gethostname(Tcl_DStringValue(&inDs),
- Tcl_DStringLength(&inDs)) == 0) {
- Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs),
- -1, &ds);
- }
- Tcl_DStringFree(&inDs);
+ Tcl_DStringInit(&inDs);
+ Tcl_DStringSetLength(&inDs, 256);
+ if (gethostname(Tcl_DStringValue(&inDs),
+ Tcl_DStringLength(&inDs)) == 0) {
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs),
+ TCL_INDEX_NONE, &ds);
}
+ Tcl_DStringFree(&inDs);
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
@@ -427,11 +417,9 @@ Tcl_GetHostName(void)
/*
*----------------------------------------------------------------------
*
- * TclpHasSockets --
+ * TclInitSockets --
*
- * This function determines whether sockets are available on the current
- * system and returns an error in interp if they are not. Note that
- * interp may be NULL.
+ * This function just calls InitSockets(), but is protected by a mutex.
*
* Results:
* Returns TCL_OK if the system supports sockets, or TCL_ERROR with an
@@ -445,24 +433,16 @@ Tcl_GetHostName(void)
*----------------------------------------------------------------------
*/
-int
-TclpHasSockets(
- Tcl_Interp *interp) /* Where to write an error message if sockets
- * are not present, or NULL if no such message
- * is to be written. */
+void
+TclInitSockets()
{
- Tcl_MutexLock(&socketMutex);
- InitSockets();
- Tcl_MutexUnlock(&socketMutex);
-
- if (SocketsEnabled()) {
- return TCL_OK;
- }
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "sockets are not available on this system", -1));
+ if (!initialized) {
+ Tcl_MutexLock(&socketMutex);
+ if (!initialized) {
+ InitSockets();
+ }
+ Tcl_MutexUnlock(&socketMutex);
}
- return TCL_ERROR;
}
/*
@@ -617,6 +597,21 @@ WaitForConnect(
}
/*
+ * In socket test mode do not continue with the connect
+ * Exceptions are:
+ * - Call by recv/send and blocking socket
+ * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING))
+ * - Call by the event queue (errorCodePtr == NULL)
+ */
+
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)
+ && errorCodePtr != NULL
+ && GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
+ *errorCodePtr = EWOULDBLOCK;
+ return -1;
+ }
+
+ /*
* Be sure to disable event servicing so we are truly modal.
*/
@@ -772,17 +767,6 @@ TcpInputProc(
*errorCodePtr = 0;
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
-
- if (!SocketsEnabled()) {
- *errorCodePtr = EFAULT;
- return -1;
- }
-
- /*
* First check to see if EOF was already detected, to prevent calling the
* socket stack after the first time EOF is detected.
*/
@@ -861,7 +845,7 @@ TcpInputProc(
if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)
|| (error != WSAEWOULDBLOCK)) {
- TclWinConvertError(error);
+ Tcl_WinConvertError(error);
*errorCodePtr = Tcl_GetErrno();
bytesRead = -1;
break;
@@ -915,17 +899,6 @@ TcpOutputProc(
*errorCodePtr = 0;
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
-
- if (!SocketsEnabled()) {
- *errorCodePtr = EFAULT;
- return -1;
- }
-
- /*
* Check if there is an async connect running.
* For blocking sockets terminate connect, otherwise do one step.
* For a non blocking socket return EWOULDBLOCK if connect not terminated
@@ -975,7 +948,7 @@ TcpOutputProc(
break;
}
} else {
- TclWinConvertError(error);
+ Tcl_WinConvertError(error);
*errorCodePtr = Tcl_GetErrno();
written = -1;
break;
@@ -1018,7 +991,7 @@ TcpOutputProc(
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
- Tcl_Interp *interp) /* Unused. */
+ TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
/* TIP #218 */
@@ -1026,28 +999,20 @@ TcpCloseProc(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
+ * Clean up the OS socket handle. The default Windows setting for a
+ * socket is SO_DONTLINGER, which does a graceful shutdown in the
+ * background.
*/
- if (SocketsEnabled()) {
- /*
- * Clean up the OS socket handle. The default Windows setting for a
- * socket is SO_DONTLINGER, which does a graceful shutdown in the
- * background.
- */
-
- while (statePtr->sockets != NULL) {
- TcpFdList *thisfd = statePtr->sockets;
+ while (statePtr->sockets != NULL) {
+ TcpFdList *thisfd = statePtr->sockets;
- statePtr->sockets = thisfd->next;
- if (closesocket(thisfd->fd) == SOCKET_ERROR) {
- TclWinConvertError((DWORD) WSAGetLastError());
- errorCode = Tcl_GetErrno();
- }
- ckfree(thisfd);
+ statePtr->sockets = thisfd->next;
+ if (closesocket(thisfd->fd) == SOCKET_ERROR) {
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
+ errorCode = Tcl_GetErrno();
}
+ ckfree(thisfd);
}
if (statePtr->addrlist != NULL) {
@@ -1133,11 +1098,11 @@ TcpClose2Proc(
*/
if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
readError = Tcl_GetErrno();
}
if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR)) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
writeError = Tcl_GetErrno();
}
return (readError != 0) ? readError : writeError;
@@ -1166,43 +1131,28 @@ TcpSetOptionProc(
const char *optionName, /* Name of the option to set. */
const char *value) /* New value for option. */
{
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
SOCKET sock;
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
-
- /*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
+ size_t len = 0;
- if (!SocketsEnabled()) {
- if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "winsock is not initialized", -1));
- }
- return TCL_ERROR;
+ if (optionName != NULL) {
+ len = strlen(optionName);
}
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
-#error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list"
sock = statePtr->sockets->fd;
- if (!strcasecmp(optionName, "-keepalive")) {
- BOOL val = FALSE;
- int boolVar, rtn;
+ if ((len > 1) && (optionName[1] == 'k') &&
+ (strncmp(optionName, "-keepalive", len) == 0)) {
+ BOOL boolVar;
+ int rtn;
if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
return TCL_ERROR;
}
- if (boolVar) {
- val = TRUE;
- }
rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE,
- (const char *) &val, sizeof(BOOL));
+ (const char *) &boolVar, sizeof(boolVar));
if (rtn != 0) {
- TclWinConvertError(WSAGetLastError());
+ Tcl_WinConvertError(WSAGetLastError());
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set socket option: %s",
@@ -1211,20 +1161,19 @@ TcpSetOptionProc(
return TCL_ERROR;
}
return TCL_OK;
- } else if (!strcasecmp(optionName, "-nagle")) {
- BOOL val = FALSE;
- int boolVar, rtn;
+ }
+ if ((len > 1) && (optionName[1] == 'n') &&
+ (strncmp(optionName, "-nodelay", len) == 0)) {
+ BOOL boolVar;
+ int rtn;
if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
return TCL_ERROR;
}
- if (!boolVar) {
- val = TRUE;
- }
rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY,
- (const char *) &val, sizeof(BOOL));
+ (const char *) &boolVar, sizeof(boolVar));
if (rtn != 0) {
- TclWinConvertError(WSAGetLastError());
+ Tcl_WinConvertError(WSAGetLastError());
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set socket option: %s",
@@ -1234,11 +1183,7 @@ TcpSetOptionProc(
}
return TCL_OK;
}
-
- return Tcl_BadChannelOption(interp, optionName, "keepalive nagle");
-#else
- return Tcl_BadChannelOption(interp, optionName, "");
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
+ return Tcl_BadChannelOption(interp, optionName, "keepalive nodelay");
}
/*
@@ -1280,26 +1225,15 @@ TcpGetOptionProc(
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
-
- if (!SocketsEnabled()) {
- if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "winsock is not initialized", -1));
- }
- return TCL_ERROR;
- }
-
- /*
* Go one step in async connect
*
* If any error is thrown save it as background error to report eventually
* below.
*/
- WaitForConnect(statePtr, NULL);
+
+ if (!GOT_BITS(statePtr->flags, TCP_ASYNC_TEST_MODE)) {
+ WaitForConnect(statePtr, NULL);
+ }
sock = statePtr->sockets->fd;
if (optionName != NULL) {
@@ -1322,7 +1256,7 @@ TcpGetOptionProc(
if (statePtr->connectError != 0) {
Tcl_DStringAppend(dsPtr,
- Tcl_ErrnoMsg(statePtr->connectError), -1);
+ Tcl_ErrnoMsg(statePtr->connectError), TCL_INDEX_NONE);
statePtr->connectError = 0;
}
} else {
@@ -1356,8 +1290,8 @@ TcpGetOptionProc(
*/
if (err) {
- TclWinConvertError(err);
- Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
+ Tcl_WinConvertError(err);
+ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), TCL_INDEX_NONE);
}
}
}
@@ -1368,7 +1302,7 @@ TcpGetOptionProc(
(strncmp(optionName, "-connecting", len) == 0)) {
Tcl_DStringAppend(dsPtr,
GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)
- ? "1" : "0", -1);
+ ? "1" : "0", TCL_INDEX_NONE);
return TCL_OK;
}
@@ -1425,7 +1359,7 @@ TcpGetOptionProc(
*/
if (len) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get peername: %s",
@@ -1501,7 +1435,7 @@ TcpGetOptionProc(
Tcl_DStringEndSublist(dsPtr);
} else {
if (interp) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get sockname: %s", Tcl_PosixError(interp)));
}
@@ -1509,54 +1443,43 @@ TcpGetOptionProc(
}
}
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'k') &&
+ (strncmp(optionName, "-keepalive", len) == 0))) {
int optlen;
BOOL opt = FALSE;
if (len == 0) {
+ sock = statePtr->sockets->fd;
Tcl_DStringAppendElement(dsPtr, "-keepalive");
}
optlen = sizeof(BOOL);
getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen);
- if (opt) {
- Tcl_DStringAppendElement(dsPtr, "1");
- } else {
- Tcl_DStringAppendElement(dsPtr, "0");
- }
+ Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0");
if (len > 0) {
return TCL_OK;
}
}
- if (len == 0 || !strncmp(optionName, "-nagle", len)) {
+ if ((len == 0) || ((len > 1) && (optionName[1] == 'n') &&
+ (strncmp(optionName, "-nodelay", len) == 0))) {
int optlen;
BOOL opt = FALSE;
if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-nagle");
+ sock = statePtr->sockets->fd;
+ Tcl_DStringAppendElement(dsPtr, "-nodelay");
}
optlen = sizeof(BOOL);
getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen);
- if (opt) {
- Tcl_DStringAppendElement(dsPtr, "0");
- } else {
- Tcl_DStringAppendElement(dsPtr, "1");
- }
+ Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0");
if (len > 0) {
return TCL_OK;
}
}
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
if (len > 0) {
-#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
return Tcl_BadChannelOption(interp, optionName,
- "connecting peername sockname keepalive nagle");
-#else
- return Tcl_BadChannelOption(interp, optionName,
- "connecting peername sockname");
-#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
+ "connecting keepalive nodelay peername sockname");
}
return TCL_OK;
@@ -1637,7 +1560,7 @@ TcpWatchProc(
static int
TcpGetHandleProc(
void *instanceData, /* The socket state. */
- int direction, /* Not used. */
+ TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
@@ -1645,8 +1568,6 @@ TcpGetHandleProc(
*handlePtr = INT2PTR(statePtr->sockets->fd);
return TCL_OK;
}
-
-
/*
*----------------------------------------------------------------------
@@ -1753,7 +1674,7 @@ TcpConnect(
*/
if (statePtr->sockets->fd == INVALID_SOCKET) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
continue;
}
@@ -1778,7 +1699,7 @@ TcpConnect(
if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
continue;
}
@@ -1849,7 +1770,7 @@ TcpConnect(
statePtr->addr->ai_addrlen);
error = WSAGetLastError();
- TclWinConvertError(error);
+ Tcl_WinConvertError(error);
if (async_connect && error == WSAEWOULDBLOCK) {
/*
@@ -1881,7 +1802,7 @@ TcpConnect(
* Get signaled connect error.
*/
- TclWinConvertError((DWORD) statePtr->notifierConnectError);
+ Tcl_WinConvertError((DWORD) statePtr->notifierConnectError);
/*
* Clear eventual connect flag.
@@ -2026,19 +1947,7 @@ Tcl_OpenTcpClient(
struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
char channelName[SOCK_CHAN_LENGTH];
- if (TclpHasSockets(interp) != TCL_OK) {
- return NULL;
- }
-
- /*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
- */
-
- if (!SocketsEnabled()) {
- return NULL;
- }
+ TclInitSockets();
/*
* Do the name lookups for the local and remote addresses.
@@ -2112,9 +2021,7 @@ Tcl_MakeTcpClientChannel(
char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
- if (TclpHasSockets(NULL) != TCL_OK) {
- return NULL;
- }
+ TclInitSockets();
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
@@ -2143,7 +2050,7 @@ Tcl_MakeTcpClientChannel(
/*
*----------------------------------------------------------------------
*
- * Tcl_OpenTcpServer --
+ * Tcl_OpenTcpServerEx --
*
* Opens a TCP server socket and creates a channel around it.
*
@@ -2158,10 +2065,13 @@ Tcl_MakeTcpClientChannel(
*/
Tcl_Channel
-Tcl_OpenTcpServer(
+Tcl_OpenTcpServerEx(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
- int port, /* Port number to open. */
+ const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
+ unsigned int flags, /* Flags. */
+ int backlog, /* Length of OS listen backlog queue, or -1
+ * for default. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
@@ -2175,25 +2085,19 @@ Tcl_OpenTcpServer(
char channelName[SOCK_CHAN_LENGTH];
u_long flag = 1; /* Indicates nonblocking mode. */
const char *errorMsg = NULL;
+ int optvalue, port;
- if (TclpHasSockets(interp) != TCL_OK) {
- return NULL;
- }
+ TclInitSockets();
/*
- * Check that WinSock is initialized; do not call it if not, to prevent
- * system crashes. This can happen at exit time if the exit handler for
- * WinSock ran before other exit handlers that want to use sockets.
+ * Construct the addresses for each end of the socket.
*/
- if (!SocketsEnabled()) {
- return NULL;
+ if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
+ errorMsg = "invalid port number";
+ goto error;
}
- /*
- * Construct the addresses for each end of the socket.
- */
-
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
&errorMsg)) {
goto error;
@@ -2203,7 +2107,7 @@ Tcl_OpenTcpServer(
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
addrPtr->ai_protocol);
if (sock == INVALID_SOCKET) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
continue;
}
@@ -2234,9 +2138,18 @@ Tcl_OpenTcpServer(
}
/*
- * Bind to the specified port. Note that we must not call
- * setsockopt with SO_REUSEADDR because Microsoft allows addresses
- * to be reused even if they are still in use.
+ * The SO_REUSEADDR option on Windows behaves like SO_REUSEPORT on
+ * unix systems.
+ */
+
+ if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) {
+ optvalue = 1;
+ (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
+ (char *) &optvalue, sizeof(optvalue));
+ }
+
+ /*
+ * Bind to the specified port.
*
* Bind should not be affected by the socket having already been
* set into nonblocking mode. If there is trouble, this is one
@@ -2245,7 +2158,7 @@ Tcl_OpenTcpServer(
if (bind(sock, addrPtr->ai_addr,
addrPtr->ai_addrlen) == SOCKET_ERROR) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
closesocket(sock);
continue;
}
@@ -2269,8 +2182,11 @@ Tcl_OpenTcpServer(
* different, and there may be differences between TCP/IP stacks).
*/
- if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
- TclWinConvertError((DWORD) WSAGetLastError());
+ if (backlog < 0) {
+ backlog = SOMAXCONN;
+ }
+ if (listen(sock, backlog) == SOCKET_ERROR) {
+ Tcl_WinConvertError((DWORD) WSAGetLastError());
closesocket(sock);
continue;
}
@@ -2455,7 +2371,7 @@ InitSockets(void)
windowClass.hCursor = NULL;
if (!RegisterClassW(&windowClass)) {
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
goto initFailure;
}
}
@@ -2502,55 +2418,19 @@ InitSockets(void)
WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
- if (tsdPtr->hwnd == NULL) {
- goto initFailure; /* Trouble creating the window. */
+ if (tsdPtr->hwnd != NULL) {
+ Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ return;
}
- Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
- return;
-
initFailure:
- TclpFinalizeSockets();
- initialized = -1;
+ Tcl_Panic("InitSockets failed");
return;
}
/*
*----------------------------------------------------------------------
*
- * SocketsEnabled --
- *
- * Check that the WinSock was successfully initialized.
- *
- * Warning:
- * This check was useful in times of Windows98 where WinSock may
- * not be available. This is not the case any more.
- * This function may be removed with TCL 9.0
- *
- * Results:
- * 1 if it is.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SocketsEnabled(void)
-{
- int enabled;
-
- Tcl_MutexLock(&socketMutex);
- enabled = (initialized == 1);
- Tcl_MutexUnlock(&socketMutex);
- return enabled;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
* SocketExitHandler --
*
* Callback invoked during exit clean up to delete the socket
@@ -2567,7 +2447,7 @@ SocketsEnabled(void)
static void
SocketExitHandler(
- void *clientData) /* Not used. */
+ TCL_UNUSED(void *))
{
Tcl_MutexLock(&socketMutex);
@@ -2601,7 +2481,7 @@ SocketExitHandler(
void
SocketSetupProc(
- void *data, /* Not used. */
+ TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
@@ -2646,7 +2526,7 @@ SocketSetupProc(
static void
SocketCheckProc(
- void *data, /* Not used. */
+ TCL_UNUSED(void *),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
@@ -3369,6 +3249,7 @@ FindFDInList(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef TclWinGetSockOpt
int
TclWinGetSockOpt(
@@ -3408,6 +3289,7 @@ TclWinGetServByName(
{
return getservbyname(name, proto);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3440,9 +3322,7 @@ TcpThreadActionProc(
* sockets will not work.
*/
- Tcl_MutexLock(&socketMutex);
- InitSockets();
- Tcl_MutexUnlock(&socketMutex);
+ TclInitSockets();
tsdPtr = TCL_TSD_INIT(&dataKey);
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index 6ca49f6..0f65268 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -3,7 +3,7 @@
*
* Contains commands for platform specific tests on Windows.
*
- * 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.
@@ -13,6 +13,11 @@
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
+#ifdef TCL_WITH_EXTERNAL_TOMMATH
+# include "tommath.h"
+#else
+# include "tclTomMath.h"
+#endif
/*
* For TestplatformChmod on Windows
@@ -96,7 +101,7 @@ TclplatformtestInit(
static int
TesteventloopCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -104,7 +109,6 @@ TesteventloopCmd(
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
- (void)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ...");
@@ -173,7 +177,7 @@ TesteventloopCmd(
static int
TestvolumetypeCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -203,7 +207,7 @@ TestvolumetypeCmd(
if (found == 0) {
Tcl_AppendResult(interp, "could not get volume type for \"",
(path?path:""), "\"", NULL);
- TclWinConvertError(GetLastError());
+ Tcl_WinConvertError(GetLastError());
return TCL_ERROR;
}
Tcl_AppendResult(interp, volType, NULL);
@@ -239,7 +243,7 @@ TestvolumetypeCmd(
static int
TestwinclockCmd(
- ClientData dummy, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
@@ -272,11 +276,11 @@ TestwinclockCmd(
result = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, result,
- Tcl_NewIntObj((int) (t2.QuadPart / 10000000)));
+ Tcl_NewWideIntObj(t2.QuadPart / 10000000));
Tcl_ListObjAppendElement(interp, result,
- Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000)));
- Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec));
- Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec));
+ Tcl_NewWideIntObj((t2.QuadPart / 10) % 1000000));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.sec));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(tclTime.usec));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart));
@@ -288,13 +292,12 @@ TestwinclockCmd(
static int
TestwinsleepCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int ms;
- (void)clientData;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "ms");
@@ -309,11 +312,12 @@ TestwinsleepCmd(
static int
TestSizeCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
+
if (objc != 2) {
goto syntax;
}
@@ -353,7 +357,7 @@ syntax:
static int
TestExceptionCmd(
- ClientData dummy, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
@@ -380,7 +384,6 @@ TestExceptionCmd(
EXCEPTION_GUARD_PAGE, EXCEPTION_INVALID_HANDLE, CONTROL_C_EXIT
};
int cmd;
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>");
@@ -633,6 +636,7 @@ TestplatformChmod(
/* Run normal chmod command */
return chmod(nativePath, pmode);
+
}
/*
@@ -656,13 +660,12 @@ TestplatformChmod(
static int
TestchmodCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int i, mode;
- (void)dummy;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?");
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index dffb5b6..e9d4e08 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -3,9 +3,9 @@
*
* This file implements the Windows-specific thread operations.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation
- * Copyright (c) 2008 by George Peter Staplin
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation
+ * 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,8 +13,6 @@
#include "tclWinInt.h"
-#include <float.h>
-
/* Workaround for mingw versions which don't provide this in float.h */
#ifndef _MCW_EM
# define _MCW_EM 0x0008001F /* Error masks */
@@ -29,10 +27,7 @@ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask
*/
static CRITICAL_SECTION globalLock;
-static int init = 0;
-#define GLOBAL_LOCK TclpGlobalLock()
-#define GLOBAL_UNLOCK TclpGlobalUnlock()
-
+static int initialized = 0;
/*
* This is the global lock used to serialize initialization and finalization
@@ -43,10 +38,10 @@ static CRITICAL_SECTION initLock;
/*
* allocLock is used by Tcl's version of malloc for synchronization. For
- * obvious reasons, cannot use any dynamically allocated storage.
+ * obvious reasons, cannot use any dyamically allocated storage.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
static struct Tcl_Mutex_ {
CRITICAL_SECTION crit;
@@ -81,7 +76,7 @@ static CRITICAL_SECTION joinLock;
* The per-thread event and queue pointers.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
typedef struct ThreadSpecificData {
HANDLE condEvent; /* Per-thread condition event */
@@ -110,7 +105,7 @@ static Tcl_ThreadDataKey dataKey;
* the queue.
*/
-typedef struct WinCondition {
+typedef struct {
CRITICAL_SECTION condLock; /* Lock to serialize queuing on the
* condition. */
struct ThreadSpecificData *firstPtr; /* Queue pointers */
@@ -122,10 +117,9 @@ typedef struct WinCondition {
*/
#ifdef USE_THREAD_ALLOC
-static int once;
static DWORD tlsKey;
-typedef struct allocMutex {
+typedef struct {
Tcl_Mutex tlock;
CRITICAL_SECTION wlock;
} allocMutex;
@@ -136,7 +130,7 @@ typedef struct allocMutex {
* to TclWinThreadStart.
*/
-typedef struct WinThread {
+typedef struct {
LPTHREAD_START_ROUTINE lpStartAddress; /* Original startup routine */
LPVOID lpParameter; /* Original startup data */
unsigned int fpControl; /* Floating point control word from the
@@ -184,7 +178,7 @@ TclWinThreadStart(
lpOrigStartAddress = winThreadPtr->lpStartAddress;
lpOrigParameter = winThreadPtr->lpParameter;
- ckfree((char *)winThreadPtr);
+ ckfree(winThreadPtr);
return lpOrigStartAddress(lpOrigParameter);
}
@@ -228,7 +222,7 @@ TclpThreadCreate(
* on WIN64 sizeof void* != sizeof unsigned
*/
-#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
+#if defined(_MSC_VER) || defined(__MSVCRT__)
tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize,
(Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr,
0, (unsigned *)idPtr);
@@ -306,7 +300,7 @@ TclpThreadExit(
TclSignalExitThread(Tcl_GetCurrentThread(), status);
LeaveCriticalSection(&joinLock);
-#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
+#if defined(_MSC_VER) || defined(__MSVCRT__)
_endthreadex((unsigned) status);
#else
ExitThread((DWORD) status);
@@ -332,7 +326,7 @@ TclpThreadExit(
Tcl_ThreadId
Tcl_GetCurrentThread(void)
{
- return (Tcl_ThreadId)(size_t)GetCurrentThreadId();
+ return (Tcl_ThreadId)INT2PTR(GetCurrentThreadId());
}
/*
@@ -357,7 +351,7 @@ Tcl_GetCurrentThread(void)
void
TclpInitLock(void)
{
- if (!init) {
+ if (!initialized) {
/*
* There is a fundamental race here that is solved by creating the
* first Tcl interpreter in a single threaded environment. Once the
@@ -365,7 +359,7 @@ TclpInitLock(void)
* that create interpreters in parallel.
*/
- init = 1;
+ initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&globalLock);
@@ -419,7 +413,7 @@ TclpInitUnlock(void)
void
TclpGlobalLock(void)
{
- if (!init) {
+ if (!initialized) {
/*
* There is a fundamental race here that is solved by creating the
* first Tcl interpreter in a single threaded environment. Once the
@@ -427,7 +421,7 @@ TclpGlobalLock(void)
* that create interpreters in parallel.
*/
- init = 1;
+ initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&globalLock);
@@ -464,7 +458,7 @@ TclpGlobalUnlock(void)
* Tcl_GetAllocMutex
*
* This procedure returns a pointer to a statically initialized mutex for
- * use by the memory allocator. The allocator must use this lock, because
+ * use by the memory allocator. The alloctor must use this lock, because
* all other locks are allocated...
*
* Results:
@@ -480,7 +474,7 @@ TclpGlobalUnlock(void)
Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (!allocOnce) {
InitializeCriticalSection(&allocLock.crit);
allocOnce = 1;
@@ -494,7 +488,7 @@ Tcl_GetAllocMutex(void)
/*
*----------------------------------------------------------------------
*
- * TclpFinalizeLock
+ * TclFinalizeLock
*
* This procedure is used to destroy all private resources used in this
* file.
@@ -512,7 +506,7 @@ Tcl_GetAllocMutex(void)
void
TclFinalizeLock(void)
{
- GLOBAL_LOCK;
+ TclpGlobalLock();
DeleteCriticalSection(&joinLock);
/*
@@ -520,9 +514,9 @@ TclFinalizeLock(void)
*/
DeleteCriticalSection(&globalLock);
- init = 0;
+ initialized = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (allocOnce) {
DeleteCriticalSection(&allocLock.crit);
allocOnce = 0;
@@ -538,7 +532,7 @@ TclFinalizeLock(void)
DeleteCriticalSection(&initLock);
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/* locally used prototype */
static void FinalizeConditionEvent(ClientData data);
@@ -567,7 +561,7 @@ Tcl_MutexLock(
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
- GLOBAL_LOCK;
+ TclpGlobalLock();
/*
* Double inside global lock check to avoid a race.
@@ -579,7 +573,7 @@ Tcl_MutexLock(
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
}
- GLOBAL_UNLOCK;
+ TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
EnterCriticalSection(csPtr);
@@ -681,7 +675,7 @@ Tcl_ConditionWait(
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
- GLOBAL_LOCK;
+ TclpGlobalLock();
/*
* Create the per-thread event and queue pointers.
@@ -695,7 +689,7 @@ Tcl_ConditionWait(
tsdPtr->flags = WIN_THREAD_RUNNING;
doExit = 1;
}
- GLOBAL_UNLOCK;
+ TclpGlobalUnlock();
if (doExit) {
/*
@@ -710,7 +704,7 @@ Tcl_ConditionWait(
}
if (*condPtr == NULL) {
- GLOBAL_LOCK;
+ TclpGlobalLock();
/*
* Initialize the per-condition queue pointers and Mutex.
@@ -724,7 +718,7 @@ Tcl_ConditionWait(
*condPtr = (Tcl_Condition) winCondPtr;
TclRememberCondition(condPtr);
}
- GLOBAL_UNLOCK;
+ TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
winCondPtr = *((WinCondition **)condPtr);
@@ -944,9 +938,9 @@ TclpFinalizeCondition(
Tcl_Mutex *
TclpNewAllocMutex(void)
{
- struct allocMutex *lockPtr;
+ allocMutex *lockPtr;
- lockPtr = (struct allocMutex *)malloc(sizeof(struct allocMutex));
+ lockPtr = (allocMutex *)malloc(sizeof(allocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
@@ -968,24 +962,24 @@ TclpFreeAllocMutex(
free(lockPtr);
}
-void *
-TclpGetAllocCache(void)
+void
+TclpInitAllocCache(void)
{
- void *result;
-
- if (!once) {
- /*
- * We need to make sure that TclpFreeAllocCache is called on each
- * thread that calls this, but only on threads that call this.
- */
+ /*
+ * We need to make sure that TclpFreeAllocCache is called on each
+ * thread that calls this, but only on threads that call this.
+ */
- tlsKey = TlsAlloc();
- once = 1;
- if (tlsKey == TLS_OUT_OF_INDEXES) {
- Tcl_Panic("could not allocate thread local storage");
- }
+ tlsKey = TlsAlloc();
+ if (tlsKey == TLS_OUT_OF_INDEXES) {
+ Tcl_Panic("could not allocate thread local storage");
}
+}
+void *
+TclpGetAllocCache(void)
+{
+ void *result;
result = TlsGetValue(tlsKey);
if ((result == NULL) && (GetLastError() != NO_ERROR)) {
Tcl_Panic("TlsGetValue failed from TclpGetAllocCache");
@@ -1023,7 +1017,7 @@ TclpFreeAllocCache(
if (!success) {
Tcl_Panic("TlsSetValue failed from TclpFreeAllocCache");
}
- } else if (once) {
+ } else {
/*
* Called by us in TclFinalizeThreadAlloc() during the library
* finalization initiated from Tcl_Finalize()
@@ -1033,9 +1027,7 @@ TclpFreeAllocCache(
if (!success) {
Tcl_Panic("TlsFree failed from TclpFreeAllocCache");
}
- once = 0; /* reset for next time. */
}
-
}
#endif /* USE_THREAD_ALLOC */
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index d77609f..6fecbd2 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -4,7 +4,7 @@
* Contains Windows specific versions of Tcl functions that obtain time
* values from the operating system.
*
- * Copyright 1995-1998 by Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -27,6 +27,7 @@
* month, where index 1 is January.
*/
+#ifndef TCL_NO_DEPRECATED
static const int normalDays[] = {
-1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364
};
@@ -35,23 +36,25 @@ static const int leapDays[] = {
-1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365
};
-typedef struct ThreadSpecificData {
+typedef struct {
char tzName[64]; /* Time zone name */
struct tm tm; /* time information */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+#endif /* TCL_NO_DEPRECATED */
/*
* Data for managing high-resolution timers.
*/
-typedef struct TimeInfo {
+typedef struct {
CRITICAL_SECTION cs; /* Mutex guarding this structure. */
int initialized; /* Flag == 1 if this structure is
* initialized. */
int perfCounterAvailable; /* Flag == 1 if the hardware has a performance
* counter. */
- DWORD calibrationInterv; /* Calibration interval in seconds (start 1 sec) */
+ DWORD calibrationInterv; /* Calibration interval in seconds (start 1
+ * sec) */
HANDLE calibrationThread; /* Handle to the thread that keeps the virtual
* clock calibrated. */
HANDLE readyEvent; /* System event used to trigger the requesting
@@ -81,9 +84,9 @@ typedef struct TimeInfo {
* Data used in developing the estimate of performance counter frequency
*/
- Tcl_WideUInt fileTimeSample[SAMPLES];
+ unsigned long long fileTimeSample[SAMPLES];
/* Last 64 samples of system time. */
- Tcl_WideInt perfCounterSample[SAMPLES];
+ long long perfCounterSample[SAMPLES];
/* Last 64 samples of performance counter. */
int sampleNo; /* Current sample number. */
} TimeInfo;
@@ -96,12 +99,12 @@ static TimeInfo timeInfo = {
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
-#ifdef HAVE_CAST_TO_UNION
- (LARGE_INTEGER) (Tcl_WideInt) 0,
+#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
+ (LARGE_INTEGER) (long long) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
- (LARGE_INTEGER) (Tcl_WideInt) 0,
- (LARGE_INTEGER) (Tcl_WideInt) 0,
- (LARGE_INTEGER) (Tcl_WideInt) 0,
+ (LARGE_INTEGER) (long long) 0,
+ (LARGE_INTEGER) (long long) 0,
+ (LARGE_INTEGER) (long long) 0,
#else
{0, 0},
{0, 0},
@@ -130,17 +133,19 @@ static struct {
* Declarations for functions defined later in this file.
*/
+#ifndef TCL_NO_DEPRECATED
static struct tm * ComputeGMT(const time_t *tp);
+#endif /* TCL_NO_DEPRECATED */
static void StopCalibration(ClientData clientData);
static DWORD WINAPI CalibrationThread(LPVOID arg);
static void UpdateTimeEachSecond(void);
-static void ResetCounterSamples(Tcl_WideUInt fileTime,
- Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);
-static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter,
- Tcl_WideUInt fileTime);
+static void ResetCounterSamples(unsigned long long fileTime,
+ long long perfCounter, long long perfFreq);
+static long long AccumulateSample(long long perfCounter,
+ unsigned long long fileTime);
static void NativeScaleTime(Tcl_Time* timebuf,
ClientData clientData);
-static Tcl_WideInt NativeGetMicroseconds(void);
+static long long NativeGetMicroseconds(void);
static void NativeGetTime(Tcl_Time* timebuf,
ClientData clientData);
@@ -153,6 +158,23 @@ Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
ClientData tclTimeClientData = NULL;
/*
+ * Inlined version of Tcl_GetTime.
+ */
+
+static inline void
+GetTime(
+ Tcl_Time *timePtr)
+{
+ tclGetTimeProcPtr(timePtr, tclTimeClientData);
+}
+
+static inline int
+IsTimeNative(void)
+{
+ return tclGetTimeProcPtr == NativeGetTime;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclpGetSeconds --
@@ -172,17 +194,18 @@ ClientData tclTimeClientData = NULL;
unsigned long
TclpGetSeconds(void)
{
- Tcl_WideInt usecSincePosixEpoch;
+ long long usecSincePosixEpoch;
- /* Try to use high resolution timer */
- if ( tclGetTimeProcPtr == NativeGetTime
- && (usecSincePosixEpoch = NativeGetMicroseconds())
- ) {
+ /*
+ * Try to use high resolution timer
+ */
+
+ if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) {
return usecSincePosixEpoch / 1000000;
} else {
Tcl_Time t;
- tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */
+ GetTime(&t);
return t.sec;
}
}
@@ -209,13 +232,14 @@ TclpGetSeconds(void)
unsigned long
TclpGetClicks(void)
{
- Tcl_WideInt usecSincePosixEpoch;
+ long long usecSincePosixEpoch;
- /* Try to use high resolution timer */
- if ( tclGetTimeProcPtr == NativeGetTime
- && (usecSincePosixEpoch = NativeGetMicroseconds())
- ) {
- return (unsigned long)usecSincePosixEpoch;
+ /*
+ * Try to use high resolution timer.
+ */
+
+ if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) {
+ return (unsigned long) usecSincePosixEpoch;
} else {
/*
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
@@ -224,7 +248,7 @@ TclpGetClicks(void)
Tcl_Time now; /* Current Tcl time */
- tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
+ GetTime(&now);
return ((unsigned long)(now.sec)*1000000UL) + (unsigned long)(now.usec);
}
}
@@ -248,7 +272,7 @@ TclpGetClicks(void)
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
TclpGetWideClicks(void)
{
LARGE_INTEGER curCounter;
@@ -261,6 +285,7 @@ TclpGetWideClicks(void)
* is consistent across all processors. Therefore, the frequency need
* only be queried upon application initialization.
*/
+
if (QueryPerformanceFrequency(&perfCounterFreq)) {
wideClick.perfCounter = 1;
wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart;
@@ -274,7 +299,7 @@ TclpGetWideClicks(void)
}
if (wideClick.perfCounter) {
if (QueryPerformanceCounter(&curCounter)) {
- return (Tcl_WideInt)curCounter.QuadPart;
+ return (long long)curCounter.QuadPart;
}
/* fallback using microseconds */
wideClick.perfCounter = 0;
@@ -307,7 +332,7 @@ double
TclpWideClickInMicrosec(void)
{
if (!wideClick.initialized) {
- (void)TclpGetWideClicks(); /* initialize */
+ (void) TclpGetWideClicks(); /* initialize */
}
return wideClick.microsecsScale;
}
@@ -329,26 +354,27 @@ TclpWideClickInMicrosec(void)
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
TclpGetMicroseconds(void)
{
- Tcl_WideInt usecSincePosixEpoch;
+ long long usecSincePosixEpoch;
- /* Try to use high resolution timer */
- if ( tclGetTimeProcPtr == NativeGetTime
- && (usecSincePosixEpoch = NativeGetMicroseconds())
- ) {
+ /*
+ * Try to use high resolution timer.
+ */
+
+ if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) {
return usecSincePosixEpoch;
} else {
/*
- * Use the Tcl_GetTime abstraction to get the time in microseconds, as
- * nearly as we can, and return it.
- */
+ * Use the Tcl_GetTime abstraction to get the time in microseconds, as
+ * nearly as we can, and return it.
+ */
Tcl_Time now;
- tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
- return (((Tcl_WideInt)now.sec) * 1000000) + now.usec;
+ GetTime(&now);
+ return (((long long) now.sec) * 1000000) + now.usec;
}
}
@@ -378,16 +404,17 @@ void
Tcl_GetTime(
Tcl_Time *timePtr) /* Location to store time information. */
{
- Tcl_WideInt usecSincePosixEpoch;
+ long long usecSincePosixEpoch;
- /* Try to use high resolution timer */
- if ( tclGetTimeProcPtr == NativeGetTime
- && (usecSincePosixEpoch = NativeGetMicroseconds())
- ) {
+ /*
+ * Try to use high resolution timer.
+ */
+
+ if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) {
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
} else {
- tclGetTimeProcPtr(timePtr, tclTimeClientData);
+ GetTime(timePtr);
}
}
@@ -410,8 +437,8 @@ Tcl_GetTime(
static void
NativeScaleTime(
- Tcl_Time *timePtr,
- ClientData clientData)
+ TCL_UNUSED(Tcl_Time *),
+ TCL_UNUSED(ClientData))
{
/*
* Native scale is 1:1. Nothing is done.
@@ -421,6 +448,96 @@ NativeScaleTime(
/*
*----------------------------------------------------------------------
*
+ * IsPerfCounterAvailable --
+ *
+ * Tests whether the performance counter is available, which is a gnarly
+ * problem on 32-bit systems. Also retrieves the nominal frequency of the
+ * performance counter.
+ *
+ * Results:
+ * 1 if the counter is available, 0 if not.
+ *
+ * Side effects:
+ * Updates fields of the timeInfo global. Make sure you hold the lock
+ * before calling this.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+IsPerfCounterAvailable(void)
+{
+ timeInfo.perfCounterAvailable =
+ QueryPerformanceFrequency(&timeInfo.nominalFreq);
+
+ /*
+ * Some hardware abstraction layers use the CPU clock in place of the
+ * real-time clock as a performance counter reference. This results in:
+ * - inconsistent results among the processors on multi-processor
+ * systems.
+ * - unpredictable changes in performance counter frequency on
+ * "gearshift" processors such as Transmeta and SpeedStep.
+ *
+ * There seems to be no way to test whether the performance counter is
+ * reliable, but a useful heuristic is that if its frequency is 1.193182
+ * MHz or 3.579545 MHz, it's derived from a colorburst crystal and is
+ * therefore the RTC rather than the TSC.
+ *
+ * A sloppier but serviceable heuristic is that the RTC crystal is
+ * normally less than 15 MHz while the TSC crystal is virtually assured to
+ * be greater than 100 MHz. Since Win98SE appears to fiddle with the
+ * definition of the perf counter frequency (perhaps in an attempt to
+ * calibrate the clock?), we use the latter rule rather than an exact
+ * match.
+ *
+ * We also assume (perhaps questionably) that the vendors have gotten
+ * their act together on Win64, so bypass all this rubbish on that
+ * platform.
+ */
+
+#if !defined(_WIN64)
+ if (timeInfo.perfCounterAvailable &&
+ /*
+ * The following lines would do an exact match on crystal
+ * frequency:
+ *
+ * timeInfo.nominalFreq.QuadPart != (long long) 1193182 &&
+ * timeInfo.nominalFreq.QuadPart != (long long) 3579545 &&
+ */
+ timeInfo.nominalFreq.QuadPart > (long long) 15000000) {
+ /*
+ * As an exception, if every logical processor on the system is on the
+ * same chip, we use the performance counter anyway, presuming that
+ * everyone's TSC is locked to the same oscillator.
+ */
+
+ SYSTEM_INFO systemInfo;
+ int regs[4];
+
+ GetSystemInfo(&systemInfo);
+ if (TclWinCPUID(0, regs) == TCL_OK
+ && regs[1] == 0x756E6547 /* "Genu" */
+ && regs[3] == 0x49656E69 /* "ineI" */
+ && regs[2] == 0x6C65746E /* "ntel" */
+ && TclWinCPUID(1, regs) == TCL_OK
+ && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
+ || ((regs[0] & 0x00F00000) /* Extended family */
+ && (regs[3] & 0x10000000))) /* Hyperthread */
+ && (((regs[1]&0x00FF0000) >> 16)/* CPU count */
+ == (int)systemInfo.dwNumberOfProcessors)) {
+ timeInfo.perfCounterAvailable = TRUE;
+ } else {
+ timeInfo.perfCounterAvailable = FALSE;
+ }
+ }
+#endif /* above code is Win32 only */
+
+ return timeInfo.perfCounterAvailable;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NativeGetMicroseconds --
*
* Gets the current system time in microseconds since the beginning
@@ -441,18 +558,18 @@ NativeScaleTime(
*----------------------------------------------------------------------
*/
-static inline Tcl_WideInt
+static inline long long
NativeCalc100NsTicks(
ULONGLONG fileTimeLastCall,
LONGLONG perfCounterLastCall,
LONGLONG curCounterFreq,
- LONGLONG curCounter
-) {
+ LONGLONG curCounter)
+{
return fileTimeLastCall +
- ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq);
+ ((curCounter - perfCounterLastCall) * 10000000 / curCounterFreq);
}
-static Tcl_WideInt
+static long long
NativeGetMicroseconds(void)
{
/*
@@ -468,79 +585,12 @@ NativeGetMicroseconds(void)
timeInfo.posixEpoch.LowPart = 0xD53E8000;
timeInfo.posixEpoch.HighPart = 0x019DB1DE;
- timeInfo.perfCounterAvailable =
- QueryPerformanceFrequency(&timeInfo.nominalFreq);
-
- /*
- * Some hardware abstraction layers use the CPU clock in place of
- * the real-time clock as a performance counter reference. This
- * results in:
- * - inconsistent results among the processors on
- * multi-processor systems.
- * - unpredictable changes in performance counter frequency on
- * "gearshift" processors such as Transmeta and SpeedStep.
- *
- * There seems to be no way to test whether the performance
- * counter is reliable, but a useful heuristic is that if its
- * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a
- * colorburst crystal and is therefore the RTC rather than the
- * TSC.
- *
- * A sloppier but serviceable heuristic is that the RTC crystal is
- * normally less than 15 MHz while the TSC crystal is virtually
- * assured to be greater than 100 MHz. Since Win98SE appears to
- * fiddle with the definition of the perf counter frequency
- * (perhaps in an attempt to calibrate the clock?), we use the
- * latter rule rather than an exact match.
- *
- * We also assume (perhaps questionably) that the vendors have
- * gotten their act together on Win64, so bypass all this rubbish
- * on that platform.
- */
-
-#if !defined(_WIN64)
- if (timeInfo.perfCounterAvailable
- /*
- * The following lines would do an exact match on crystal
- * frequency:
- * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182
- * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545
- */
- && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){
- /*
- * As an exception, if every logical processor on the system
- * is on the same chip, we use the performance counter anyway,
- * presuming that everyone's TSC is locked to the same
- * oscillator.
- */
-
- SYSTEM_INFO systemInfo;
- unsigned int regs[4];
-
- GetSystemInfo(&systemInfo);
- if (TclWinCPUID(0, regs) == TCL_OK
- && regs[1] == 0x756E6547 /* "Genu" */
- && regs[3] == 0x49656E69 /* "ineI" */
- && regs[2] == 0x6C65746E /* "ntel" */
- && TclWinCPUID(1, regs) == TCL_OK
- && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
- || ((regs[0] & 0x00F00000) /* Extended family */
- && (regs[3] & 0x10000000))) /* Hyperthread */
- && (((regs[1]&0x00FF0000) >> 16)/* CPU count */
- == systemInfo.dwNumberOfProcessors)) {
- timeInfo.perfCounterAvailable = TRUE;
- } else {
- timeInfo.perfCounterAvailable = FALSE;
- }
- }
-#endif /* above code is Win32 only */
-
/*
* If the performance counter is available, start a thread to
* calibrate it.
*/
- if (timeInfo.perfCounterAvailable) {
+ if (IsPerfCounterAvailable()) {
DWORD id;
InitializeCriticalSection(&timeInfo.cs);
@@ -574,7 +624,8 @@ NativeGetMicroseconds(void)
ULONGLONG fileTimeLastCall;
LONGLONG perfCounterLastCall, curCounterFreq;
- /* Copy with current data of calibration cycle */
+ /* Copy with current data of calibration
+ * cycle. */
LARGE_INTEGER curCounter;
/* Current performance counter. */
@@ -584,6 +635,7 @@ NativeGetMicroseconds(void)
/*
* Hold time section locked as short as possible
*/
+
EnterCriticalSection(&timeInfo.cs);
fileTimeLastCall = timeInfo.fileTimeLastCall.QuadPart;
@@ -615,11 +667,14 @@ NativeGetMicroseconds(void)
*/
if (curCounter.QuadPart - perfCounterLastCall <
- 11 * curCounterFreq * timeInfo.calibrationInterv / 10
- ) {
- /* Calibrated file-time is saved from Posix in 100-ns ticks */
+ 11 * curCounterFreq * timeInfo.calibrationInterv / 10) {
+ /*
+ * Calibrated file-time is saved from Posix in 100-ns ticks.
+ */
+
return NativeCalc100NsTicks(fileTimeLastCall,
- perfCounterLastCall, curCounterFreq, curCounter.QuadPart) / 10;
+ perfCounterLastCall, curCounterFreq,
+ curCounter.QuadPart) / 10;
}
}
@@ -649,25 +704,27 @@ NativeGetMicroseconds(void)
static void
NativeGetTime(
Tcl_Time *timePtr,
- ClientData clientData)
+ TCL_UNUSED(ClientData))
{
- Tcl_WideInt usecSincePosixEpoch;
+ long long usecSincePosixEpoch;
/*
* Try to use high resolution timer.
*/
- if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) {
+
+ usecSincePosixEpoch = NativeGetMicroseconds();
+ if (usecSincePosixEpoch) {
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
} else {
/*
- * High resolution timer is not available. Just use ftime.
- */
+ * High resolution timer is not available. Just use ftime.
+ */
struct _timeb t;
_ftime(&t);
- timePtr->sec = (long)t.time;
+ timePtr->sec = (long) t.time;
timePtr->usec = t.millitm * 1000;
}
}
@@ -694,7 +751,7 @@ void TclWinResetTimerResolution(void);
static void
StopCalibration(
- ClientData unused) /* Client data is unused */
+ TCL_UNUSED(ClientData))
{
SetEvent(timeInfo.exitEvent);
@@ -726,6 +783,7 @@ StopCalibration(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGetDate(
const time_t *t,
@@ -733,14 +791,14 @@ TclpGetDate(
{
struct tm *tmPtr;
time_t time;
-#if defined(_WIN64) || (defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400))
-# define t2 *t /* no need to cripple time to 32-bit */
+#if defined(_WIN64) || defined(_USE_64BIT_TIME_T)
+# define t2 *t /* no need to cripple time to 32-bit */
#else
- time_t t2 = *(__time32_t *)t;
+ time_t t2 = *(__time32_t *) t;
#endif
if (!useGMT) {
-#if defined(_MSC_VER) && (_MSC_VER >= 1900)
+#if defined(_MSC_VER)
# undef timezone /* prevent conflict with timezone() function */
long timezone = 0;
#endif
@@ -753,28 +811,11 @@ TclpGetDate(
* daylight savings time before the epoch.
*/
- /*
- * Hmm, Borland's localtime manages to return NULL under certain
- * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
- * since 'localtime' isn't supposed to do this, possibly leading to
- * crashes.
- *
- * Patch: We only call this function if we are at least one day into
- * the epoch, else we handle it ourselves (like we do for times < 0).
- * H. Giese, June 2003
- */
-
-#ifdef __BORLANDC__
-#define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY
-#else
-#define LOCALTIME_VALIDITY_BOUNDARY 0
-#endif
-
- if (t2 >= LOCALTIME_VALIDITY_BOUNDARY) {
+ if (t2 >= 0) {
return TclpLocaltime(&t2);
}
-#if defined(_MSC_VER) && (_MSC_VER >= 1900)
+#if defined(_MSC_VER)
_get_timezone(&timezone);
#endif
@@ -805,14 +846,14 @@ TclpGetDate(
time -= 60;
}
- time = tmPtr->tm_min + time/60;
+ time = tmPtr->tm_min + time / 60;
tmPtr->tm_min = (int)(time % 60);
if (tmPtr->tm_min < 0) {
tmPtr->tm_min += 60;
time -= 60;
}
- time = tmPtr->tm_hour + time/60;
+ time = tmPtr->tm_hour + time / 60;
tmPtr->tm_hour = (int)(time % 24);
if (tmPtr->tm_hour < 0) {
tmPtr->tm_hour += 24;
@@ -820,9 +861,9 @@ TclpGetDate(
}
time /= 24;
- tmPtr->tm_mday += (int)time;
- tmPtr->tm_yday += (int)time;
- tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7;
+ tmPtr->tm_mday += (int) time;
+ tmPtr->tm_yday += (int) time;
+ tmPtr->tm_wday = (tmPtr->tm_wday + (int) time) % 7;
}
} else {
tmPtr = ComputeGMT(&t2);
@@ -863,8 +904,8 @@ ComputeGMT(
* Compute the 4 year span containing the specified time.
*/
- tmp = (long)(*tp / SECSPER4YEAR);
- rem = (long)(*tp % SECSPER4YEAR);
+ tmp = (long) (*tp / SECSPER4YEAR);
+ rem = (long) (*tp % SECSPER4YEAR);
/*
* Correct for weird mod semantics so the remainder is always positive.
@@ -931,7 +972,7 @@ ComputeGMT(
* Compute day of week. Epoch started on a Thursday.
*/
- tmPtr->tm_wday = (long)(*tp / SECSPERDAY) + 4;
+ tmPtr->tm_wday = (long) (*tp / SECSPERDAY) + 4;
if ((*tp % SECSPERDAY) < 0) {
tmPtr->tm_wday--;
}
@@ -942,6 +983,7 @@ ComputeGMT(
return tmPtr;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -971,7 +1013,7 @@ ComputeGMT(
static DWORD WINAPI
CalibrationThread(
- LPVOID arg)
+ TCL_UNUSED(LPVOID))
{
FILETIME curFileTime;
DWORD waitResult;
@@ -985,7 +1027,11 @@ CalibrationThread(
QueryPerformanceFrequency(&timeInfo.curCounterFreq);
timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
- /* Calibrated file-time will be saved from Posix in 100-ns ticks */
+
+ /*
+ * Calibrated file-time will be saved from Posix in 100-ns ticks.
+ */
+
timeInfo.fileTimeLastCall.QuadPart -= timeInfo.posixEpoch.QuadPart;
ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart,
@@ -1049,12 +1095,12 @@ UpdateTimeEachSecond(void)
/* File time of the previous calibration */
LARGE_INTEGER curFileTime; /* File time at the time this callback was
* scheduled. */
- Tcl_WideInt estFreq; /* Estimated perf counter frequency. */
- Tcl_WideInt vt0; /* Tcl time right now. */
- Tcl_WideInt vt1; /* Tcl time one second from now. */
- Tcl_WideInt tdiff; /* Difference between system clock and Tcl
+ long long estFreq; /* Estimated perf counter frequency. */
+ long long vt0; /* Tcl time right now. */
+ long long vt1; /* Tcl time one second from now. */
+ long long tdiff; /* Difference between system clock and Tcl
* time. */
- Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into
+ long long driftFreq; /* Frequency needed to drift virtual time into
* step over 1 second. */
/*
@@ -1065,12 +1111,17 @@ UpdateTimeEachSecond(void)
curFileTime.LowPart = curSysTime.dwLowDateTime;
curFileTime.HighPart = curSysTime.dwHighDateTime;
curFileTime.QuadPart -= timeInfo.posixEpoch.QuadPart;
- /* If calibration still not needed (check for possible time switch) */
- if ( curFileTime.QuadPart > lastFileTime.QuadPart
- && curFileTime.QuadPart < lastFileTime.QuadPart +
- (timeInfo.calibrationInterv * 10000000)
- ) {
- /* again in next one second */
+
+ /*
+ * If calibration still not needed (check for possible time switch)
+ */
+
+ if (curFileTime.QuadPart > lastFileTime.QuadPart && curFileTime.QuadPart <
+ lastFileTime.QuadPart + (timeInfo.calibrationInterv * 10000000)) {
+ /*
+ * Look again in next one second.
+ */
+
return;
}
QueryPerformanceCounter(&curPerfCounter);
@@ -1106,7 +1157,7 @@ UpdateTimeEachSecond(void)
*/
estFreq = AccumulateSample(curPerfCounter.QuadPart,
- (Tcl_WideUInt) curFileTime.QuadPart);
+ (unsigned long long) curFileTime.QuadPart);
/*
* We want to adjust things so that time appears to be continuous.
@@ -1126,8 +1177,9 @@ UpdateTimeEachSecond(void)
*/
vt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart,
- timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart,
- curPerfCounter.QuadPart);
+ timeInfo.perfCounterLastCall.QuadPart,
+ timeInfo.curCounterFreq.QuadPart, curPerfCounter.QuadPart);
+
/*
* If we've gotten more than a second away from system time, then drifting
* the clock is going to be pretty hopeless. Just let it jump. Otherwise,
@@ -1136,17 +1188,25 @@ UpdateTimeEachSecond(void)
tdiff = vt0 - curFileTime.QuadPart;
if (tdiff > 10000000 || tdiff < -10000000) {
- /* jump to current system time, use curent estimated frequency */
+ /*
+ * Jump to current system time, use curent estimated frequency.
+ */
+
vt0 = curFileTime.QuadPart;
} else {
- /* calculate new frequency and estimate drift to the next second */
+ /*
+ * Calculate new frequency and estimate drift to the next second.
+ */
+
vt1 = 20000000 + curFileTime.QuadPart;
driftFreq = (estFreq * 20000000 / (vt1 - vt0));
+
/*
- * Avoid too large drifts (only half of the current difference),
- * that allows also be more accurate (aspire to the smallest tdiff),
- * so then we can prolong calibration interval by tdiff < 100000
+ * Avoid too large drifts (only half of the current difference), that
+ * allows also be more accurate (aspire to the smallest tdiff), so
+ * then we can prolong calibration interval by tdiff < 100000
*/
+
driftFreq = timeInfo.curCounterFreq.QuadPart +
(driftFreq - timeInfo.curCounterFreq.QuadPart) / 2;
@@ -1154,50 +1214,78 @@ UpdateTimeEachSecond(void)
* Average between estimated, 2 current and 5 drifted frequencies,
* (do the soft drifting as possible)
*/
- estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart + 5 * driftFreq) / 8;
+
+ estFreq = (estFreq + 2 * timeInfo.curCounterFreq.QuadPart +
+ 5 * driftFreq) / 8;
}
- /* Avoid too large discrepancy from nominal frequency */
- if (estFreq > 1003*timeInfo.nominalFreq.QuadPart/1000) {
- estFreq = 1003*timeInfo.nominalFreq.QuadPart/1000;
+ /*
+ * Avoid too large discrepancy from nominal frequency.
+ */
+
+ if (estFreq > 1003 * timeInfo.nominalFreq.QuadPart / 1000) {
+ estFreq = 1003 * timeInfo.nominalFreq.QuadPart / 1000;
vt0 = curFileTime.QuadPart;
- } else if (estFreq < 997*timeInfo.nominalFreq.QuadPart/1000) {
- estFreq = 997*timeInfo.nominalFreq.QuadPart/1000;
+ } else if (estFreq < 997 * timeInfo.nominalFreq.QuadPart / 1000) {
+ estFreq = 997 * timeInfo.nominalFreq.QuadPart / 1000;
vt0 = curFileTime.QuadPart;
} else if (vt0 != curFileTime.QuadPart) {
/*
- * Be sure the clock ticks never backwards (avoid it by negative drifting)
- * just compare native time (in 100-ns) before and hereafter using
- * new calibrated values) and do a small adjustment (short time freeze)
+ * Be sure the clock ticks never backwards (avoid it by negative
+ * drifting). Just compare native time (in 100-ns) before and
+ * hereafter using new calibrated values) and do a small adjustment
+ * (short time freeze).
*/
+
LARGE_INTEGER newPerfCounter;
- Tcl_WideInt nt0, nt1;
+ long long nt0, nt1;
QueryPerformanceCounter(&newPerfCounter);
nt0 = NativeCalc100NsTicks(timeInfo.fileTimeLastCall.QuadPart,
- timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart,
- newPerfCounter.QuadPart);
+ timeInfo.perfCounterLastCall.QuadPart,
+ timeInfo.curCounterFreq.QuadPart, newPerfCounter.QuadPart);
nt1 = NativeCalc100NsTicks(vt0,
- curPerfCounter.QuadPart, estFreq,
- newPerfCounter.QuadPart);
- if (nt0 > nt1) { /* drifted backwards, try to compensate with new base */
- /* first adjust with a micro jump (short frozen time is acceptable) */
+ curPerfCounter.QuadPart, estFreq, newPerfCounter.QuadPart);
+ if (nt0 > nt1) {
+ /*
+ * Drifted backwards, try to compensate with new base.
+ *
+ * First adjust with a micro jump (short frozen time is
+ * acceptable).
+ */
vt0 += nt0 - nt1;
- /* if drift unavoidable (e. g. we had a time switch), then reset it */
+
+ /*
+ * If drift unavoidable (e. g. we had a time switch), then reset
+ * it.
+ */
+
vt1 = vt0 - curFileTime.QuadPart;
if (vt1 > 10000000 || vt1 < -10000000) {
- /* larger jump resp. shift relative new file-time */
+ /*
+ * Larger jump resp. shift relative new file-time.
+ */
+
vt0 = curFileTime.QuadPart;
}
}
}
- /* In lock commit new values to timeInfo (hold lock as short as possible) */
+ /*
+ * In lock commit new values to timeInfo (hold lock as short as possible)
+ */
+
EnterCriticalSection(&timeInfo.cs);
- /* grow calibration interval up to 10 seconds (if still precise enough) */
+ /*
+ * Grow calibration interval up to 10 seconds (if still precise enough)
+ */
+
if (tdiff < -100000 || tdiff > 100000) {
- /* too long drift - reset calibration interval to 1000 second */
+ /*
+ * Too long drift. Reset calibration interval to 1000 second.
+ */
+
timeInfo.calibrationInterv = 1;
} else if (timeInfo.calibrationInterv < 10) {
timeInfo.calibrationInterv++;
@@ -1231,12 +1319,13 @@ UpdateTimeEachSecond(void)
static void
ResetCounterSamples(
- Tcl_WideUInt fileTime, /* Current file time */
- Tcl_WideInt perfCounter, /* Current performance counter */
- Tcl_WideInt perfFreq) /* Target performance frequency */
+ unsigned long long fileTime,/* Current file time */
+ long long perfCounter, /* Current performance counter */
+ long long perfFreq) /* Target performance frequency */
{
int i;
- for (i=SAMPLES-1 ; i>=0 ; --i) {
+
+ for (i = SAMPLES - 1 ; i >= 0 ; --i) {
timeInfo.perfCounterSample[i] = perfCounter;
timeInfo.fileTimeSample[i] = fileTime;
perfCounter -= perfFreq;
@@ -1271,20 +1360,22 @@ ResetCounterSamples(
* case).
*/
-static Tcl_WideInt
+static long long
AccumulateSample(
- Tcl_WideInt perfCounter,
- Tcl_WideUInt fileTime)
+ long long perfCounter,
+ unsigned long long fileTime)
{
- Tcl_WideUInt workFTSample; /* File time sample being removed from or
+ unsigned long long workFTSample;
+ /* File time sample being removed from or
* added to the circular buffer. */
- Tcl_WideInt workPCSample; /* Performance counter sample being removed
+ long long workPCSample; /* Performance counter sample being removed
* from or added to the circular buffer. */
- Tcl_WideUInt lastFTSample; /* Last file time sample recorded */
- Tcl_WideInt lastPCSample; /* Last performance counter sample recorded */
- Tcl_WideInt FTdiff; /* Difference between last FT and current */
- Tcl_WideInt PCdiff; /* Difference between last PC and current */
- Tcl_WideInt estFreq; /* Estimated performance counter frequency */
+ unsigned long long lastFTSample;
+ /* Last file time sample recorded */
+ long long lastPCSample; /* Last performance counter sample recorded */
+ long long FTdiff; /* Difference between last FT and current */
+ long long PCdiff; /* Difference between last PC and current */
+ long long estFreq; /* Estimated performance counter frequency */
/*
* Test for jumps and reset the samples if we have one.
@@ -1318,7 +1409,7 @@ AccumulateSample(
estFreq = 10000000 * (perfCounter - workPCSample)
/ (fileTime - workFTSample);
timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter;
- timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime;
+ timeInfo.fileTimeSample[timeInfo.sampleNo] = (long long) fileTime;
/*
* Advance the sample number.
@@ -1348,6 +1439,7 @@ AccumulateSample(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGmtime(
const time_t *timePtr) /* Pointer to the number of seconds since the
@@ -1359,11 +1451,11 @@ TclpGmtime(
* Posix gmtime_r function.
*/
-#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
+#if defined(_WIN64) || defined(_USE_64BIT_TIME_T)
return gmtime(timePtr);
#else
- return _gmtime32((const __time32_t *)timePtr);
-#endif
+ return _gmtime32((const __time32_t *) timePtr);
+#endif /* _WIN64 || _USE_64BIT_TIME_T */
}
/*
@@ -1394,12 +1486,13 @@ TclpLocaltime(
* provide a Posix localtime_r function.
*/
-#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
+#if defined(_WIN64) || defined(_USE_64BIT_TIME_T)
return localtime(timePtr);
#else
- return _localtime32((const __time32_t *)timePtr);
-#endif
+ return _localtime32((const __time32_t *) timePtr);
+#endif /* _WIN64 || _USE_64BIT_TIME_T */
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh
index 2279542..a400b5b 100644
--- a/win/tclooConfig.sh
+++ b/win/tclooConfig.sh
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
TCLOO_INCLUDE_SPEC=""
TCLOO_PRIVATE_INCLUDE_SPEC=""
TCLOO_CFLAGS=""
-TCLOO_VERSION=1.1.0
+TCLOO_VERSION=1.3
diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in
index 8b06fce..dc652e6 100644
--- a/win/tclsh.exe.manifest.in
+++ b/win/tclsh.exe.manifest.in
@@ -28,8 +28,6 @@
<supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}"/>
<!-- Windows 7 -->
<supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}"/>
- <!-- Windows Vista -->
- <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}"/>
</application>
</compatibility>
<asmv3:application>
@@ -37,6 +35,10 @@
xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
<dpiAware>true</dpiAware>
</asmv3:windowsSettings>
+ <asmv3:windowsSettings
+ xmlns="http://schemas.microsoft.com/SMI/2019/WindowsSettings">
+ <activeCodePage>UTF-8</activeCodePage>
+ </asmv3:windowsSettings>
</asmv3:application>
<dependency>
<dependentAssembly>
diff --git a/win/tclsh.rc b/win/tclsh.rc
index 685bebd1..f439d08 100644
--- a/win/tclsh.rc
+++ b/win/tclsh.rc
@@ -8,12 +8,6 @@
//
// build-up the name suffix that defines the type of build this is.
//
-#if TCL_THREADS
-#define SUFFIX_THREADS "t"
-#else
-#define SUFFIX_THREADS ""
-#endif
-
#if STATIC_BUILD
#define SUFFIX_STATIC "s"
#else
@@ -26,7 +20,7 @@
#define SUFFIX_DEBUG ""
#endif
-#define SUFFIX SUFFIX_THREADS SUFFIX_STATIC SUFFIX_DEBUG
+#define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
diff --git a/win/x86_64-w64-mingw32-nmakehlp.exe b/win/x86_64-w64-mingw32-nmakehlp.exe
index 2564ec9..f821add 100755
--- a/win/x86_64-w64-mingw32-nmakehlp.exe
+++ b/win/x86_64-w64-mingw32-nmakehlp.exe
Binary files differ