summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.fossil-settings/binary-glob22
-rw-r--r--.github/ISSUE_TEMPLATE.md3
-rw-r--r--.github/PULL_REQUEST_TEMPLATE.md3
-rw-r--r--.project2
-rw-r--r--.travis.yml103
-rw-r--r--ChangeLog.20072
-rw-r--r--README.md10
-rw-r--r--changes181
-rw-r--r--compat/fake-rfc2553.c3
-rw-r--r--compat/float.h14
-rw-r--r--compat/mkstemp.c13
-rw-r--r--compat/opendir.c2
-rw-r--r--compat/stdint.h919
-rw-r--r--compat/stdlib.h2
-rw-r--r--compat/unistd.h76
-rw-r--r--compat/waitpid.c2
-rw-r--r--doc/AddErrInfo.35
-rw-r--r--doc/CrtInterp.36
-rw-r--r--doc/CrtObjCmd.329
-rw-r--r--doc/Encoding.318
-rw-r--r--doc/Ensemble.34
-rw-r--r--doc/Eval.35
-rw-r--r--doc/Exit.33
-rw-r--r--doc/FileSystem.310
-rw-r--r--doc/FindExec.34
-rw-r--r--doc/GetInt.37
-rw-r--r--doc/Hash.32
-rw-r--r--doc/InitStubs.36
-rw-r--r--doc/InitSubSyst.331
-rw-r--r--doc/IntObj.319
-rw-r--r--doc/Interp.3121
-rw-r--r--doc/LinkVar.3146
-rw-r--r--doc/Method.344
-rw-r--r--doc/Notifier.332
-rw-r--r--doc/OpenTcp.318
-rw-r--r--doc/Panic.320
-rw-r--r--doc/RecEvalObj.32
-rw-r--r--doc/SaveResult.3107
-rw-r--r--doc/SetResult.321
-rw-r--r--doc/StaticPkg.33
-rw-r--r--doc/StringObj.310
-rw-r--r--doc/Tcl.n8
-rw-r--r--doc/Tcl_Main.32
-rw-r--r--doc/Thread.312
-rw-r--r--doc/ToUpper.313
-rw-r--r--doc/TraceVar.333
-rw-r--r--doc/UniCharIsAlpha.32
-rw-r--r--doc/Utf.390
-rw-r--r--doc/abstract.n77
-rw-r--r--doc/append.n12
-rw-r--r--doc/array.n62
-rw-r--r--doc/binary.n362
-rw-r--r--doc/callback.n88
-rw-r--r--doc/catch.n6
-rw-r--r--doc/cd.n6
-rw-r--r--doc/chan.n10
-rw-r--r--doc/classvariable.n78
-rw-r--r--doc/clock.n39
-rw-r--r--doc/close.n4
-rw-r--r--doc/continue.n2
-rw-r--r--doc/cookiejar.n217
-rw-r--r--doc/coroutine.n108
-rw-r--r--doc/dde.n6
-rw-r--r--doc/define.n597
-rw-r--r--doc/dict.n55
-rw-r--r--doc/eof.n4
-rw-r--r--doc/exec.n2
-rw-r--r--doc/exit.n4
-rw-r--r--doc/expr.n456
-rw-r--r--doc/fblocked.n4
-rw-r--r--doc/file.n34
-rw-r--r--doc/fileevent.n4
-rw-r--r--doc/filename.n4
-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.n115
-rw-r--r--doc/idna.n88
-rw-r--r--doc/incr.n9
-rw-r--r--doc/info.n651
-rw-r--r--doc/interp.n4
-rw-r--r--doc/join.n4
-rw-r--r--doc/lappend.n15
-rw-r--r--doc/lassign.n4
-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/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/lset.n5
-rw-r--r--doc/lsort.n7
-rw-r--r--doc/mathfunc.n81
-rw-r--r--doc/mathop.n67
-rw-r--r--doc/msgcat.n205
-rw-r--r--doc/my.n93
-rw-r--r--doc/namespace.n4
-rw-r--r--doc/next.n5
-rw-r--r--doc/open.n146
-rw-r--r--doc/package.n12
-rw-r--r--doc/packagens.n4
-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/re_syntax.n6
-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/self.n7
-rw-r--r--doc/set.n4
-rw-r--r--doc/singleton.n99
-rw-r--r--doc/socket.n10
-rw-r--r--doc/source.n6
-rw-r--r--doc/string.n47
-rw-r--r--doc/tclsh.19
-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/update.n4
-rw-r--r--doc/uplevel.n4
-rw-r--r--doc/while.n4
-rw-r--r--doc/zipfs.3120
-rw-r--r--doc/zipfs.n254
-rw-r--r--generic/regc_lex.c6
-rw-r--r--generic/regc_locale.c4
-rw-r--r--generic/regc_nfa.c4
-rw-r--r--generic/regcomp.c35
-rw-r--r--generic/regcustom.h11
-rw-r--r--generic/regerror.c1
-rw-r--r--generic/regex.h4
-rw-r--r--generic/regexec.c17
-rw-r--r--generic/regguts.h35
-rw-r--r--generic/tcl.decls317
-rw-r--r--generic/tcl.h686
-rw-r--r--generic/tclAlloc.c88
-rw-r--r--generic/tclAssembly.c198
-rw-r--r--generic/tclAsync.c2
-rw-r--r--generic/tclBasic.c1884
-rw-r--r--generic/tclBinary.c642
-rw-r--r--generic/tclCkalloc.c308
-rw-r--r--generic/tclClock.c99
-rw-r--r--generic/tclCmdAH.c536
-rw-r--r--generic/tclCmdIL.c872
-rw-r--r--generic/tclCmdMZ.c1052
-rw-r--r--generic/tclCompCmds.c200
-rw-r--r--generic/tclCompCmdsGR.c223
-rw-r--r--generic/tclCompCmdsSZ.c452
-rw-r--r--generic/tclCompExpr.c118
-rw-r--r--generic/tclCompile.c309
-rw-r--r--generic/tclCompile.h93
-rw-r--r--generic/tclConfig.c33
-rw-r--r--generic/tclDate.c3
-rw-r--r--generic/tclDecls.h807
-rw-r--r--generic/tclDictObj.c588
-rw-r--r--generic/tclDisassemble.c139
-rw-r--r--generic/tclEncoding.c423
-rw-r--r--generic/tclEnsemble.c256
-rw-r--r--generic/tclEnv.c11
-rw-r--r--generic/tclEvent.c107
-rw-r--r--generic/tclExecute.c1896
-rw-r--r--generic/tclFCmd.c173
-rw-r--r--generic/tclFileName.c80
-rw-r--r--generic/tclGet.c2
-rw-r--r--generic/tclGetDate.y3
-rw-r--r--generic/tclHash.c142
-rw-r--r--generic/tclHistory.c15
-rw-r--r--generic/tclIO.c322
-rw-r--r--generic/tclIO.h6
-rw-r--r--generic/tclIOCmd.c245
-rw-r--r--generic/tclIOGT.c91
-rw-r--r--generic/tclIORChan.c222
-rw-r--r--generic/tclIORTrans.c164
-rw-r--r--generic/tclIOSock.c102
-rw-r--r--generic/tclIOUtil.c2280
-rw-r--r--generic/tclIndexObj.c120
-rw-r--r--generic/tclInt.decls104
-rw-r--r--generic/tclInt.h769
-rw-r--r--generic/tclIntDecls.h337
-rw-r--r--generic/tclIntPlatDecls.h28
-rw-r--r--generic/tclInterp.c296
-rw-r--r--generic/tclLink.c1320
-rw-r--r--generic/tclListObj.c1024
-rw-r--r--generic/tclLiteral.c108
-rw-r--r--generic/tclLoad.c106
-rw-r--r--generic/tclMain.c41
-rw-r--r--generic/tclNamesp.c396
-rw-r--r--generic/tclNotify.c2
-rw-r--r--generic/tclOO.c646
-rw-r--r--generic/tclOO.decls7
-rw-r--r--generic/tclOO.h11
-rw-r--r--generic/tclOOBasic.c184
-rw-r--r--generic/tclOOCall.c999
-rw-r--r--generic/tclOODecls.h13
-rw-r--r--generic/tclOODefineCmds.c840
-rw-r--r--generic/tclOOInfo.c310
-rw-r--r--generic/tclOOInt.h101
-rw-r--r--generic/tclOOMethod.c245
-rw-r--r--generic/tclOOScript.h263
-rw-r--r--generic/tclOOStubInit.c1
-rw-r--r--generic/tclObj.c1457
-rw-r--r--generic/tclOptimize.c10
-rw-r--r--generic/tclPanic.c9
-rw-r--r--generic/tclParse.c294
-rw-r--r--generic/tclParse.h2
-rw-r--r--generic/tclPathObj.c504
-rw-r--r--generic/tclPipe.c90
-rw-r--r--generic/tclPkg.c538
-rw-r--r--generic/tclPkgConfig.c4
-rw-r--r--generic/tclPlatDecls.h14
-rw-r--r--generic/tclPort.h15
-rw-r--r--generic/tclPreserve.c19
-rw-r--r--generic/tclProc.c418
-rw-r--r--generic/tclProcess.c958
-rw-r--r--generic/tclRegexp.c88
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclResolve.c6
-rw-r--r--generic/tclResult.c118
-rw-r--r--generic/tclScan.c107
-rw-r--r--generic/tclStrToD.c918
-rw-r--r--generic/tclStringObj.c1455
-rw-r--r--generic/tclStringRep.h13
-rw-r--r--generic/tclStubInit.c748
-rw-r--r--generic/tclStubLib.c34
-rw-r--r--generic/tclTest.c1296
-rw-r--r--generic/tclTestObj.c146
-rw-r--r--generic/tclTestProcBodyObj.c18
-rw-r--r--generic/tclThread.c43
-rw-r--r--generic/tclThreadAlloc.c119
-rw-r--r--generic/tclThreadJoin.c2
-rw-r--r--generic/tclThreadStorage.c18
-rw-r--r--generic/tclThreadTest.c63
-rw-r--r--generic/tclTimer.c82
-rw-r--r--generic/tclTomMath.decls160
-rw-r--r--generic/tclTomMath.h1147
-rw-r--r--generic/tclTomMathDecls.h529
-rw-r--r--generic/tclTomMathInterface.c134
-rw-r--r--generic/tclTomMathStubLib.c5
-rw-r--r--generic/tclTrace.c137
-rw-r--r--generic/tclUtf.c580
-rw-r--r--generic/tclUtil.c714
-rw-r--r--generic/tclVar.c1661
-rw-r--r--generic/tclZipfs.c5027
-rw-r--r--generic/tclZlib.c168
-rw-r--r--generic/tommath.h1
-rw-r--r--library/auto.tcl51
-rw-r--r--library/cookiejar/cookiejar.tcl746
-rw-r--r--library/cookiejar/effective_tld_names.txt.gzbin0 -> 70836 bytes
-rw-r--r--library/cookiejar/idna.tcl292
-rw-r--r--library/cookiejar/pkgIndex.tcl3
-rw-r--r--library/dde/pkgIndex.tcl2
-rw-r--r--library/http/http.tcl121
-rw-r--r--library/http1.0/http.tcl377
-rw-r--r--library/http1.0/pkgIndex.tcl11
-rw-r--r--library/init.tcl105
-rw-r--r--library/install.tcl244
-rw-r--r--library/manifest.txt20
-rw-r--r--library/msgcat/msgcat.tcl334
-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.tcl20
-rw-r--r--library/reg/pkgIndex.tcl2
-rw-r--r--library/safe.tcl47
-rw-r--r--library/tclIndex135
-rw-r--r--library/word.tcl24
-rw-r--r--libtommath/appveyor.yml1
-rw-r--r--libtommath/bn_deprecated.c4
-rw-r--r--libtommath/bn_mp_expt_u32.c2
-rw-r--r--libtommath/bn_mp_log_u32.c18
-rw-r--r--libtommath/bn_mp_radix_smap.c2
-rw-r--r--libtommath/bn_mp_root_u32.c4
-rw-r--r--libtommath/bn_mp_set_double.c4
-rw-r--r--libtommath/bn_mp_to_ubin.c3
-rw-r--r--libtommath/bn_s_mp_mul_high_digs_fast.c4
-rw-r--r--libtommath/bn_s_mp_rand_jenkins.c4
-rw-r--r--libtommath/changes.txt2
-rwxr-xr-xlibtommath/helper.pl2
-rw-r--r--libtommath/makefile_include.mk8
-rw-r--r--libtommath/tommath.h92
-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/libtommath.dllbin0 -> 81408 bytes
-rw-r--r--libtommath/win64/libtommath.dll.abin0 -> 128166 bytes
-rwxr-xr-xlibtommath/win64/tommath.libbin0 -> 29044 bytes
-rw-r--r--macosx/GNUmakefile4
-rw-r--r--macosx/README6
-rw-r--r--macosx/Tcl-Common.xcconfig6
-rw-r--r--macosx/Tcl.xcode/project.pbxproj27
-rw-r--r--macosx/Tcl.xcodeproj/project.pbxproj27
-rw-r--r--macosx/configure.ac2
-rw-r--r--macosx/tclMacOSXBundle.c7
-rw-r--r--macosx/tclMacOSXFCmd.c66
-rw-r--r--macosx/tclMacOSXNotify.c130
-rw-r--r--tests-perf/test-performance.tcl2
-rw-r--r--tests/apply.test2
-rw-r--r--tests/assemble.test89
-rw-r--r--tests/assemble1.bench19
-rw-r--r--tests/async.test7
-rw-r--r--tests/autoMkindex.test2
-rw-r--r--tests/basic.test32
-rw-r--r--tests/binary.test90
-rw-r--r--tests/case.test5
-rw-r--r--tests/chan.test4
-rw-r--r--tests/chanio.test8
-rw-r--r--tests/clock.test8
-rw-r--r--tests/cmdAH.test60
-rw-r--r--tests/cmdIL.test86
-rw-r--r--tests/cmdMZ.test25
-rw-r--r--tests/compExpr-old.test37
-rw-r--r--tests/compExpr.test12
-rw-r--r--tests/compile.test27
-rw-r--r--tests/config.test2
-rw-r--r--tests/coroutine.test161
-rw-r--r--tests/dict.test119
-rw-r--r--tests/encoding.test72
-rw-r--r--tests/env.test6
-rw-r--r--tests/event.test6
-rw-r--r--tests/exec.test5
-rw-r--r--tests/execute.test22
-rw-r--r--tests/expr-old.test66
-rw-r--r--tests/expr.test266
-rw-r--r--tests/fCmd.test16
-rw-r--r--tests/fileSystem.test4
-rw-r--r--tests/fileSystemEncoding.test2
-rw-r--r--tests/for.test78
-rw-r--r--tests/format.test86
-rw-r--r--tests/get.test32
-rw-r--r--tests/history.test2
-rw-r--r--tests/http.test459
-rw-r--r--tests/httpTest.tcl6
-rw-r--r--tests/httpcookie.test876
-rw-r--r--tests/httpd9
-rw-r--r--tests/httpold.test300
-rw-r--r--tests/incr.test12
-rw-r--r--tests/indexObj.test2
-rw-r--r--tests/info.test200
-rw-r--r--tests/init.test10
-rw-r--r--tests/internals.tcl4
-rw-r--r--tests/interp.test56
-rw-r--r--tests/io.test150
-rw-r--r--tests/ioCmd.test191
-rw-r--r--tests/ioTrans.test2
-rw-r--r--tests/iogt.test2
-rw-r--r--tests/lindex.test121
-rw-r--r--tests/link.test497
-rw-r--r--tests/lmap.test6
-rw-r--r--tests/lpop.test145
-rw-r--r--tests/lrange.test117
-rw-r--r--tests/lrepeat.test4
-rw-r--r--tests/lreplace.test32
-rw-r--r--tests/lsearch.test162
-rw-r--r--tests/lset.test40
-rw-r--r--tests/lsetComp.test510
-rw-r--r--tests/main.test2
-rw-r--r--tests/mathop.test44
-rw-r--r--tests/misc.test4
-rw-r--r--tests/msgcat.test300
-rw-r--r--tests/namespace.test34
-rw-r--r--tests/nre.test6
-rw-r--r--tests/obj.test99
-rw-r--r--tests/oo.test1370
-rw-r--r--tests/ooUtil.test563
-rw-r--r--tests/package.test177
-rw-r--r--tests/parse.test2
-rw-r--r--tests/parseExpr.test9
-rw-r--r--tests/pkgIndex.tcl2
-rw-r--r--tests/pkgMkIndex.test2
-rw-r--r--tests/platform.test20
-rw-r--r--tests/proc.test6
-rw-r--r--tests/process.test341
-rw-r--r--tests/reg.test6
-rw-r--r--tests/regexp.test257
-rw-r--r--tests/regexpComp.test62
-rw-r--r--tests/result.test4
-rw-r--r--tests/safe.test14
-rw-r--r--tests/scan.test24
-rw-r--r--tests/set-old.test4
-rw-r--r--tests/socket.test1102
-rw-r--r--tests/source.test15
-rw-r--r--tests/split.test9
-rw-r--r--tests/stack.test2
-rw-r--r--tests/string.test2921
-rw-r--r--tests/stringComp.test801
-rw-r--r--tests/stringObj.test19
-rw-r--r--tests/subst.test2
-rw-r--r--tests/tailcall.test12
-rw-r--r--tests/tcltests.tcl4
-rw-r--r--tests/thread.test7
-rw-r--r--tests/trace.test60
-rw-r--r--tests/unixFCmd.test14
-rw-r--r--tests/unixForkEvent.test2
-rw-r--r--tests/unixInit.test17
-rw-r--r--tests/unixNotfy.test13
-rw-r--r--tests/uplevel.test32
-rw-r--r--tests/upvar.test2
-rw-r--r--tests/utf.test222
-rw-r--r--tests/util.test1482
-rw-r--r--tests/var.test438
-rw-r--r--tests/winFCmd.test70
-rw-r--r--tests/winFile.test18
-rw-r--r--tests/winPipe.test8
-rw-r--r--tests/zipfs.test284
-rw-r--r--tests/zlib.test4
-rwxr-xr-xtools/configure2949
-rw-r--r--tools/configure.ac (renamed from tools/configure.in)4
-rwxr-xr-xtools/fix_tommath_h.tcl102
-rw-r--r--tools/genStubs.tcl10
-rw-r--r--tools/installVfs.tcl54
-rwxr-xr-xtools/loadICU.tcl3
-rw-r--r--tools/makeHeader.tcl182
-rw-r--r--tools/mkVfs.tcl99
-rw-r--r--tools/tcl.hpj.in4
-rw-r--r--tools/tclOOScript.tcl456
-rw-r--r--tools/tcltk-man2html-utils.tcl13
-rwxr-xr-xtools/tcltk-man2html.tcl95
-rw-r--r--tools/tsdPerf.c10
-rw-r--r--unix/Makefile.in707
-rw-r--r--unix/README2
-rwxr-xr-xunix/configure19217
-rw-r--r--unix/configure.ac (renamed from unix/configure.in)185
-rw-r--r--unix/dltest/Makefile.in2
-rw-r--r--unix/dltest/pkga.c12
-rw-r--r--unix/dltest/pkgc.c16
-rw-r--r--unix/dltest/pkgd.c16
-rw-r--r--unix/dltest/pkge.c13
-rw-r--r--unix/dltest/pkgooa.c2
-rw-r--r--unix/dltest/pkgua.c29
-rwxr-xr-xunix/installManPage43
-rw-r--r--unix/tcl.m4516
-rw-r--r--unix/tcl.pc.in4
-rw-r--r--unix/tcl.spec2
-rw-r--r--unix/tclAppInit.c2
-rw-r--r--unix/tclConfig.h.in51
-rw-r--r--unix/tclConfig.sh.in8
-rw-r--r--unix/tclEpollNotfy.c837
-rw-r--r--unix/tclKqueueNotfy.c853
-rw-r--r--unix/tclLoadAix.c24
-rw-r--r--unix/tclLoadDl.c42
-rw-r--r--unix/tclLoadDyld.c46
-rw-r--r--unix/tclLoadNext.c2
-rw-r--r--unix/tclLoadOSF.c2
-rw-r--r--unix/tclLoadShl.c2
-rw-r--r--unix/tclSelectNotfy.c1124
-rw-r--r--unix/tclUnixChan.c693
-rw-r--r--unix/tclUnixCompat.c56
-rw-r--r--unix/tclUnixFCmd.c357
-rw-r--r--unix/tclUnixFile.c70
-rw-r--r--unix/tclUnixInit.c79
-rw-r--r--unix/tclUnixNotfy.c1393
-rw-r--r--unix/tclUnixPipe.c66
-rw-r--r--unix/tclUnixPort.h55
-rw-r--r--unix/tclUnixSock.c209
-rw-r--r--unix/tclUnixTest.c320
-rw-r--r--unix/tclUnixThrd.c314
-rw-r--r--unix/tclUnixThrd.h19
-rw-r--r--unix/tclUnixTime.c22
-rw-r--r--unix/tclXtNotify.c10
-rw-r--r--unix/tclXtTest.c4
-rw-r--r--unix/tclooConfig.sh2
-rw-r--r--win/Makefile.in292
-rw-r--r--win/README8
-rwxr-xr-x[-rw-r--r--]win/buildall.vc.bat4
-rw-r--r--win/coffbase.txt43
-rwxr-xr-xwin/configure6779
-rw-r--r--win/configure.ac (renamed from win/configure.in)74
-rw-r--r--win/makefile.vc104
-rw-r--r--win/tcl.dsp42
-rw-r--r--win/tcl.hpj.in4
-rw-r--r--win/tcl.m4284
-rw-r--r--win/tcl.rc8
-rw-r--r--win/tclAppInit.c15
-rw-r--r--win/tclConfig.sh.in9
-rw-r--r--win/tclWin32Dll.c166
-rw-r--r--win/tclWinChan.c227
-rw-r--r--win/tclWinConsole.c320
-rw-r--r--win/tclWinError.c9
-rw-r--r--win/tclWinFCmd.c211
-rw-r--r--win/tclWinFile.c107
-rw-r--r--win/tclWinInit.c90
-rw-r--r--win/tclWinInt.h26
-rw-r--r--win/tclWinLoad.c15
-rw-r--r--win/tclWinNotify.c63
-rw-r--r--win/tclWinPanic.c88
-rw-r--r--win/tclWinPipe.c118
-rw-r--r--win/tclWinPort.h20
-rw-r--r--win/tclWinSerial.c166
-rw-r--r--win/tclWinSock.c821
-rw-r--r--win/tclWinTest.c54
-rw-r--r--win/tclWinThrd.c100
-rw-r--r--win/tclWinTime.c29
-rw-r--r--win/tclooConfig.sh2
-rw-r--r--win/tclsh.rc8
572 files changed, 67542 insertions, 47582 deletions
diff --git a/.fossil-settings/binary-glob b/.fossil-settings/binary-glob
index ec574be..a6eec26 100644
--- a/.fossil-settings/binary-glob
+++ b/.fossil-settings/binary-glob
@@ -4,6 +4,26 @@ compat/zlib/win64/zdll.lib
compat/zlib/win64/zlib1.dll
compat/zlib/win64/libz.dll.a
compat/zlib/zlib.3.pdf
+compat/zlib/win32/zdll.lib
+compat/zlib/win32/zlib1.dll
+compat/zlib/win64/zdll.lib
+compat/zlib/win64/zlib1.dll
+compat/zlib/win64/libz.dll.a
+compat/zlib/zlib.3.pdf
+libtommath/win32/tommath.lib
+libtommath/win32/libtommath.dll
+libtommath/win64/tommath.lib
+libtommath/win64/libtommath.dll
+libtommath/win64/libtommath.dll.a
+*.a
*.bmp
+*.dll
+*.exe
*.gif
-*.png \ No newline at end of file
+*.gz
+*.jpg
+*.lib
+*.pdf
+*.png
+*.xlsx
+*.zip
diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md
new file mode 100644
index 0000000..22d3860
--- /dev/null
+++ b/.github/ISSUE_TEMPLATE.md
@@ -0,0 +1,3 @@
+Important Note
+==========
+Please do not file issues with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there.
diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md
new file mode 100644
index 0000000..da07cd2
--- /dev/null
+++ b/.github/PULL_REQUEST_TEMPLATE.md
@@ -0,0 +1,3 @@
+Important Note
+==========
+Please do not file pull requests with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues (including patches) are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there.
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 77e52ea..6ab1540 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -30,13 +30,13 @@ matrix:
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: bionic
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: bionic
@@ -58,6 +58,14 @@ matrix:
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
+# C++ build.
+ - name: "Linux/G++/Shared"
+ os: linux
+ dist: bionic
+ compiler: g++
+ env:
+ - BUILD_DIR=unix
+ - CFGOPT="CC=g++ CFLAGS=-Dregister=dont+use+register"
# Older versions of GCC...
- name: "Linux/GCC 7/Shared"
os: linux
@@ -102,6 +110,13 @@ matrix:
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: bionic
@@ -124,7 +139,7 @@ matrix:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
- - name: "macOS/Xcode 11.5/Shared"
+ - name: "macOS/Clang/Xcode 11.5/Shared"
os: osx
osx_image: xcode11.5
env:
@@ -134,40 +149,60 @@ matrix:
- make all
# The styles=develop avoids some weird problems on OSX
- make test styles=develop
- - name: "macOS/Xcode 11.5/Shared/Unix-like"
+ - name: "macOS/Clang/Xcode 11.5/Shared/Unix-like"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=unix
+ - name: "macOS/Clang++/Xcode 11.5/Shared"
+ os: osx
+ osx_image: xcode11.5
+ env:
+ - BUILD_DIR=unix
+ - CFGOPT="CC=clang++ --enable-framework CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern"
+ script:
+ - make all tcltest
# Older MacOS versions
- - name: "macOS/Xcode 11/Shared"
+ - name: "macOS/Clang/Xcode 11/Shared"
os: osx
osx_image: xcode11
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"
+ addons:
+ homebrew:
+ packages:
+ - libtommath
+ - name: "macOS/Clang/Xcode 9/Shared"
os: osx
osx_image: xcode9.2
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- - name: "macOS/Xcode 8/Shared"
+ addons:
+ homebrew:
+ packages:
+ - libtommath
+ - name: "macOS/Clang/Xcode 8/Shared"
os: osx
osx_image: xcode8.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
+ addons:
+ homebrew:
+ packages:
+ - libtommath
# Test with mingw-w64 cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows/GCC/Shared/no test"
@@ -215,6 +250,15 @@ matrix:
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-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=nodep' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC/Static"
os: windows
compiler: cl
@@ -261,6 +305,15 @@ matrix:
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-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 'OPTS=nodep' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Static"
os: windows
compiler: cl
@@ -296,7 +349,7 @@ matrix:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- - choco install -y make
+ - choco install -y make zip
- cd ${BUILD_DIR}
- name: "Windows/GCC/Shared: UTF_MAX=4"
os: windows
@@ -305,6 +358,22 @@ matrix:
- 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/G++/Shared"
+ os: windows
+ compiler: g++
+ env:
+ - BUILD_DIR=win
+ - CFGOPT="CC=g++ --enable-64bit"
+ before_install: *makepreinst
+ script:
+ - make all tcltest
- name: "Windows/GCC/Static"
os: windows
compiler: gcc
@@ -340,6 +409,22 @@ matrix:
- 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/G++-x86/Shared"
+ os: windows
+ compiler: g++
+ env:
+ - BUILD_DIR=win
+ - CFGOPT="CC=g++"
+ before_install: *makepreinst
+ script:
+ - make all tcltest
- name: "Windows/GCC-x86/Static"
os: windows
compiler: gcc
diff --git a/ChangeLog.2007 b/ChangeLog.2007
index 5995956..34725e3 100644
--- a/ChangeLog.2007
+++ b/ChangeLog.2007
@@ -1426,7 +1426,7 @@
initialization assumptions of the TIP 280 code in CompileWord().
* generic/tclCompExpr.c: Suppress the attempt to convert to
- numeric when pre-compiling a constant expresion indicates an error.
+ numeric when pre-compiling a constant expression indicates an error.
2007-08-22 Miguel Sofer <msofer@users.sf.net>
diff --git a/README.md b/README.md
index 3b192a5..242b3b1 100644
--- a/README.md
+++ b/README.md
@@ -1,11 +1,11 @@
# README: Tcl
-This is the **Tcl 8.6.10** source distribution.
+This is the **Tcl 8.7a4** source distribution.
You can get any source release of Tcl from [our distribution
site](https://sourceforge.net/projects/tcl/files/Tcl/).
-[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-6-branch)](https://travis-ci.org/tcltk/tcl)
+[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-branch)](https://travis-ci.org/tcltk/tcl)
## Contents
1. [Introduction](#intro)
@@ -43,7 +43,7 @@ and selling it either in whole or in part. See the file
## <a id="doc">2.</a> Documentation
Extensive documentation is available at our website.
The home page for this release, including new features, is
-[here](https://www.tcl.tk/software/tcltk/8.6.html).
+[here](https://www.tcl.tk/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.
@@ -53,8 +53,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 090846f..a448f82 100644
--- a/changes
+++ b/changes
@@ -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 --- http://core.tcl.tk/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)
@@ -8941,7 +8990,133 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich)
2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres)
-2019-11-18 (bug)[13657a] application/json us text, not binary (noe,nijtmans)
-=> http 2.9.1
-
- Released 8.6.10, Nov 21, 2019 - details at http://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-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 --- http://core.tcl-lang.org/tcl/ for details -
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 1a44dfa..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";
- register char *a, *b;
+ 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/stdlib.h b/compat/stdlib.h
index 6900be3..bb0f133 100644
--- a/compat/stdlib.h
+++ b/compat/stdlib.h
@@ -5,7 +5,7 @@
* This file isn't complete in the ANSI-C sense; it only declares things
* that are needed by Tcl. This file is needed even on many systems with
* their own stdlib.h (e.g. SunOS) because not all stdlib.h files declare
- * all the procedures needed here (such as strtod).
+ * all the procedures needed here (such as strtol/strtoul).
*
* Copyright (c) 1991 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
diff --git a/compat/unistd.h b/compat/unistd.h
deleted file mode 100644
index a8f14f2..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 **argv);
-extern int execve(const char *path, char **argv, char **envp);
-extern int execvpw(const char *file, char **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 seteuidw(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/doc/AddErrInfo.3 b/doc/AddErrInfo.3
index caba125..5b0fe5a 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
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/CrtObjCmd.3 b/doc/CrtObjCmd.3
index 6714bd7..2cd9222 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_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj, Tcl_RegisterCommandTypeName, Tcl_GetCommandTypeName \- implement new commands in C
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -42,6 +42,14 @@ void
.sp
Tcl_Command
\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)
+.sp
+.VS "info cmdtype feature"
+void
+\fBTcl_RegisterCommandTypeName\fR(\fIproc, typeName\fR)
+.sp
+const char *
+\fBTcl_GetCommandTypeName\fR(\fItoken\fR)
+.VE "info cmdtype feature"
.SH ARGUMENTS
.AS Tcl_CmdDeleteProc *deleteProc in/out
.AP Tcl_Interp *interp in
@@ -65,6 +73,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
@@ -296,6 +307,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
+.VS "info cmdtype feature"
+\fBTcl_RegisterCommandTypeName\fR is used to associate a name (the
+\fItypeName\fR argument) with a particular implementation function so that it
+can then be looked up with \fBTcl_GetCommandTypeName\fR, which in turn is
+called with a command token that information is wanted for and which returns
+the name of the type that was registered for the implementation function used
+for that command. (The lookup functionality is surfaced virtually directly in Tcl via
+\fBinfo cmdtype\fR.) If there is no function registered for a particular
+function, the result will be the string literal
+.QW \fBnative\fR .
+The registration of a name can be undone by registering a mapping to NULL
+instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that
+string which was registered, and not a copy; use of a compile-time constant
+string is \fIstrongly recommended\fR.
+.VE "info cmdtype feature"
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3)
.SH KEYWORDS
diff --git a/doc/Encoding.3 b/doc/Encoding.3
index 79fca0f..2d2461e 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_ExternalToUtf, Tcl_UtfToExternalDString, 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
@@ -255,11 +255,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
diff --git a/doc/Ensemble.3 b/doc/Ensemble.3
index 30c1d3b..febc48f 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)
.
diff --git a/doc/Eval.3 b/doc/Eval.3
index e241794..1abe6f2 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -150,13 +150,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
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/FileSystem.3 b/doc/FileSystem.3
index 28ee8f0..3b50232 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -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)
@@ -146,7 +144,6 @@ Tcl_Obj *
Tcl_StatBuf *
\fBTcl_AllocStatBuf\fR()
.sp
-.VS 8.6
Tcl_WideInt
\fBTcl_GetAccessTimeFromStat\fR(\fIstatPtr\fR)
.sp
@@ -185,7 +182,6 @@ Tcl_WideUInt
.sp
int
\fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR)
-.VE 8.6
.SH ARGUMENTS
.AS Tcl_GlobTypeData **srcPathPtr out
.AP "const Tcl_Filesystem" *fsPtr in
@@ -444,20 +440,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 +787,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 +810,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
diff --git a/doc/FindExec.3 b/doc/FindExec.3
index 1fd57db..149ef8a 100644
--- a/doc/FindExec.3
+++ b/doc/FindExec.3
@@ -58,6 +58,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/GetInt.3 b/doc/GetInt.3
index 5a3304a..eba549d 100644
--- a/doc/GetInt.3
+++ b/doc/GetInt.3
@@ -57,6 +57,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
@@ -65,8 +68,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
diff --git a/doc/Hash.3 b/doc/Hash.3
index 4dc3623..aa79b86 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
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..3c138a4
--- /dev/null
+++ b/doc/InitSubSyst.3
@@ -0,0 +1,31 @@
+'\"
+'\" 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
+void
+\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
+\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 unicode 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..e793303 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_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -32,6 +32,9 @@ 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
@@ -55,6 +58,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
@@ -97,7 +102,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, \fB__int64\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 +120,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
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..92e7d03 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_BYTES\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,179 @@ 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_BYTES\fR instead.
+.VE "TIP 312"
+.RE
+.TP
+\fBTCL_LINK_BYTES\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.
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 +262,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 +272,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/Method.3 b/doc/Method.3
index 225da00..9e636a1 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.
diff --git a/doc/Notifier.3 b/doc/Notifier.3
index 16f9f8d..ec9f910 100644
--- a/doc/Notifier.3
+++ b/doc/Notifier.3
@@ -132,22 +132,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
@@ -403,11 +398,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 +489,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/OpenTcp.3 b/doc/OpenTcp.3
index 4a7dc1e..5b941dc 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, 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,9 @@ 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 "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 +167,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..53b84da 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
@@ -21,6 +21,9 @@ void
void
\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:
@@ -75,6 +86,9 @@ 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 +96,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/RecEvalObj.3 b/doc/RecEvalObj.3
index 1b0f292..f9550a2 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)
diff --git a/doc/SaveResult.3 b/doc/SaveResult.3
index 6dd6cb6..e62d22d 100644
--- a/doc/SaveResult.3
+++ b/doc/SaveResult.3
@@ -1,6 +1,7 @@
'\"
'\" Copyright (c) 1997 by 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.
@@ -9,7 +10,9 @@
.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
+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
@@ -30,91 +33,53 @@ int
.SH ARGUMENTS
.AS Tcl_InterpState savedPtr
.AP Tcl_Interp *interp in
-Interpreter for which state should be saved.
+The interpreter for the operation.
.AP int status in
-Return code value to save as part of interpreter state.
+The return code for the state.
.AP Tcl_InterpState state in
-Saved state token to be restored or discarded.
+A token for saved state.
.AP Tcl_SavedResult *savedPtr in
-Pointer to location where interpreter result should be saved or restored.
+A pointer to storage for saved state.
.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.
+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
-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.
+\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
-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).
+\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
-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.
+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_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.
+\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_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.
+\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_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_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 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_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
-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.
+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/SetResult.3 b/doc/SetResult.3
index e50650e..1622290 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
diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3
index 41e2d65..b22edcc 100644
--- a/doc/StaticPkg.3
+++ b/doc/StaticPkg.3
@@ -64,6 +64,9 @@ 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_StaticPackage\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"
diff --git a/doc/StringObj.3 b/doc/StringObj.3
index 7870b21..2b665cc 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
@@ -204,8 +204,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
@@ -249,7 +249,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.
diff --git a/doc/Tcl.n b/doc/Tcl.n
index fc3b477..0eb51b9 100644
--- a/doc/Tcl.n
+++ b/doc/Tcl.n
@@ -28,10 +28,10 @@ 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
+Secondly, the first word is used to locate a routine to
+carry out the command, and the remaining words of the command are
+passed to that routine.
+The routine 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.
diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3
index 3ec33d1..dc4f45f 100644
--- a/doc/Tcl_Main.3
+++ b/doc/Tcl_Main.3
@@ -189,6 +189,8 @@ 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 "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 629a8e5..fd9ddfb 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 c3edfa4..82aa7b8 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,8 @@ 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"
-.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.
.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..61490ed 100644
--- a/doc/UniCharIsAlpha.3
+++ b/doc/UniCharIsAlpha.3
@@ -48,7 +48,7 @@ int
.SH ARGUMENTS
.AS int ch
.AP int ch in
-The Tcl_UniChar to be examined.
+The Unicode character to be examined.
.BE
.SH DESCRIPTION
diff --git a/doc/Utf.3 b/doc/Utf.3
index d8debf5..263d4dd 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_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,30 @@ 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_UniCharLen\fR(\fIuniStr\fR)
.sp
@@ -63,7 +81,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 +93,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 +116,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 +144,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 +152,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 +174,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 0x0080 and
+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.
@@ -200,7 +236,7 @@ of \fIlength\fR bytes is long enough to be decoded by
\fBTcl_UtfToUniChar\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.
+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 +244,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
@@ -246,21 +282,25 @@ byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte
\fIsrc[-\fBTCL_UTF_MAX\fI-1]\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/abstract.n b/doc/abstract.n
new file mode 100644
index 0000000..022c24b
--- /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 TclOO
+
+\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 92a939a..0e8b28e 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
@@ -135,7 +130,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
@@ -150,7 +144,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
@@ -158,6 +154,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
@@ -185,29 +182,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
@@ -215,42 +246,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
@@ -258,43 +309,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
@@ -304,22 +378,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
@@ -334,22 +418,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
@@ -365,20 +459,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
@@ -401,11 +499,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
@@ -422,11 +525,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
@@ -439,26 +547,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
@@ -467,14 +586,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
@@ -496,8 +623,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
@@ -511,6 +639,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
@@ -522,12 +651,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
@@ -539,14 +671,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
@@ -557,8 +692,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
@@ -567,24 +703,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
@@ -595,13 +737,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
@@ -609,9 +754,11 @@ 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
@@ -622,13 +769,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
@@ -636,9 +786,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
@@ -647,135 +799,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
@@ -784,9 +952,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
@@ -806,9 +976,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
@@ -824,28 +996,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
@@ -856,9 +1036,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..95838a9
--- /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 TclOO
+
+\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 81aa9f4..962992b 100644
--- a/doc/chan.n
+++ b/doc/chan.n
@@ -35,7 +35,6 @@ turned on by default.
.
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
@@ -45,7 +44,6 @@ 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
.RS
.PP
As part of closing the channel, all buffered output is flushed to the
@@ -83,12 +81,10 @@ 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
.RE
.TP
\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
@@ -540,7 +536,6 @@ 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.
.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
@@ -561,16 +556,13 @@ 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.
.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
.
@@ -609,7 +601,6 @@ executed in the interpreter that set them up.
.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
@@ -618,7 +609,6 @@ 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
.
diff --git a/doc/classvariable.n b/doc/classvariable.n
new file mode 100644
index 0000000..0798bb2
--- /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 TclOO
+
+\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 f0f6c37..a85f29f 100644
--- a/doc/clock.n
+++ b/doc/clock.n
@@ -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,40 +886,46 @@ 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,
where \fBT\fR is the literal
.QW T ,
.QW "\fICCyymmdd hhmmss\fR" ,
or
-.QW \fICCyymmdd\fBT\fIhh:mm:ss\fR .
+.QW \fICCyymmdd\fBT\fIhh\fB:\fImm\fB:\fIss\fR .
Note that only these three 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..0d8b81a
--- /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.tk/]
+.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.tk/]
+.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/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 ac3d8ed..cf7376e 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..9046203 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.
@@ -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 cd7e94c..ff56b22 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 \fIdictionaryVarable\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 \fIdictionaryVarable\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 \fIdictionaryVarable\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 \fIdictionaryVarable\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 \fIdictionaryVarable\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 \fIdictionaryVarable\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 \fIdictionaryVarable\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/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 99dfdc5..855a192 100644
--- a/doc/exec.n
+++ b/doc/exec.n
@@ -338,7 +338,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
@@ -352,7 +351,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 1fd4c4e..1498ba1 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
+The \fIexpr\fR command 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,78 +32,53 @@ 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 an expression evaluates to an integer, the value is the decimal form of
+the integer, and when an expression evaluates to a floating-point number, the
+value is the form produced by the \fB%g\fR format specifier of Tcl's
+\fBformat\fR command.
.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:
+An expression consists of a combination of operands, operators, parentheses and
+commas, possibly with whitespace between any of these elements, which is
+ignored.
+.PP
+An operand 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
\fBboolean\fR.
.IP [3]
-As a Tcl variable, using standard \fB$\fR notation.
-The variable's value will be used as the operand.
+As a variable, using standard \fB$\fR notation.
+The value of the variable is then the value of 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
+Backslash, variable, and command substitution are performed as described in
+\fBTcl\fR.
.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.
+The operand is treated as a braced value as described in \fBTcl\fR.
.IP [6]
As a Tcl command enclosed in brackets.
-The command will be executed and its result will be used as
-the operand.
+Command substitution is performed as described in \fBTcl\fR.
.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
+As 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.
.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
@@ -112,37 +87,87 @@ will produce the value on the right side of the line:
\fBexpr\fR 4*[llength "6 2"] \fI8\fR
\fBexpr\fR {{word one} < "word $a"} \fI0\fR
.CE
+.PP
+\fBInteger value\fR
+.PP
+An integer operand may be specified in decimal (the normal case, the optional
+first two characters are \fB0d\fR), binary
+(the first two characters are \fB0b\fR), octal
+(the first two characters are \fB0o\fR), or hexadecimal
+(the first two characters are \fB0x\fR) form. 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
+\fBFloating-point value\fR
+.PP
+A floating-point number may be specified in 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
+\fBBoolean value\fR
+.PP
+A boolean value may be represented by any of the values \fB0\fR, \fBfalse\fR, \fBno\fR,
+or \fBoff\fR and any of the values \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR.
+.PP
+\fBDigit Separator\fR
+.PP
+Digits in any numeric value may be separated with one or more underscore
+characters, "\fB_\fR", to improve readability. These separators may only
+appear between digits. The separator may 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
+.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 +177,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 +359,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 +395,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 +422,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,8 +482,8 @@ 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 {
@@ -487,12 +501,12 @@ 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 (c) 1993 The Regents of the University of California.
-Copyright (c) 1994-2000 Sun Microsystems Incorporated.
-Copyright (c) 2005 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
+Copyright \(co 1993 The Regents of the University of California.
+Copyright \(co 1994-2000 Sun Microsystems Incorporated.
+Copyright \(co 2005 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
.fi
'\" Local Variables:
'\" mode: nroff
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/file.n b/doc/file.n
index 2f8b70c..da602fd 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -390,7 +390,7 @@ that use the third component do not attempt to perform tilde
substitution.
.RE
.TP
-\fBfile stat \fIname varName\fR
+\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.
@@ -433,9 +433,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
@@ -450,7 +479,6 @@ 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 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 87ba467..f160eff 100644
--- a/doc/filename.n
+++ b/doc/filename.n
@@ -176,3 +176,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..5bf21c5
--- /dev/null
+++ b/doc/fpclassify.n
@@ -0,0 +1,83 @@
+'\"
+'\" Copyright (c) 2018 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved
+'\" Copyright (c) 2019 by 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 e8c8c90..7552a5f 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -13,10 +13,10 @@
.SH NAME
http \- Client-side implementation of the HTTP/1.1 protocol
.SH SYNOPSIS
-\fBpackage require http ?2.9?\fR
+\fBpackage require http\fI ?\fB2.9\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
@@ -99,6 +99,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
@@ -770,6 +779,108 @@ Subsequent GET and HEAD requests in a failed pipeline will also be retried.
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 EXAMPLE
.PP
This example creates a procedure to copy a URL to a file while printing a
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 477e272..dc21ac1 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -13,95 +13,102 @@
.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 \fBslave\fR
+\fIcommandName\fR was created by \fBinterp create\fR.
+.IP \fBzlibStream\fR
+\fIcommandName\fR was created by \fBzlib stream\fR.
+.PP
+Other types may be also registered as well. See \fBTcl_RegisterCommandTypeName\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 +116,103 @@ identifies the
.QW "inner context" ,
which is the innermost atomic command or bytecode instruction that raised the
error, along with its arguments when available. While \fBCALL\fR and \fBUP\fR
-allow to follow complex call paths, \fBINNER\fR homes in on the offending
-operation in the innermost procedure call, even going to sub-expression
+provide a trail of the call path, \fBINNER\fR provides details of the offending
+operation in the innermost procedure call, even to sub-expression
granularity.
.PP
This information is also present in the \fB\-errorstack\fR entry of the
options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR
is a convenient way of retrieving it for uncaught errors at top-level in an
-interactive \fBtclsh\fR.
+interactive \fBinterpreter\fR.
.RE
-.VE 8.6
.TP
\fBinfo exists \fIvarName\fR
.
-Returns \fB1\fR if the variable named \fIvarName\fR exists in the
-current context (either as a global or local variable) and has been
-defined by being given a value, returns \fB0\fR otherwise.
+Returns \fB1\fR if a variable named \fIvarName\fR is visible and has been
+defined, and \fB0\fR otherwise.
.TP
-\fBinfo frame\fR ?\fInumber\fR?
+\fBinfo frame\fR ?\fIdepth\fR?
.
-This command provides access to all frames on the stack, even those
-hidden from \fBinfo level\fR. If \fInumber\fR is not specified, this
-command returns a number giving the frame level of the command. This
-is 1 if the command is invoked at top-level. If \fInumber\fR is
-specified, then the result is a dictionary containing the location
-information for the command at the \fInumber\fRed level on the stack.
+Returns the depth of the call to \fBinfo frame\fR itself. Otherwise, returns a
+dictionary describing the active command at the \fIdepth\fR, which counts all
+commands visible to \fBinfo level\fR, plus commands that don't create a new
+level, such as \fBeval\fR, \fBsource\fR, or \fIuplevel\fR. The frame depth is
+always greater than the current level.
.RS
.PP
-If \fInumber\fR is positive (> 0) then it selects a particular stack
-level (1 refers to the outer-most active command, 2 to the command it
-called, and so on, up to the current frame level which refers to
-\fBinfo frame\fR itself); otherwise it gives a level relative to the
-current command (0 refers to the current command, i.e., \fBinfo
-frame\fR itself, -1 to its caller, and so on).
-.PP
-This is similar to how \fBinfo level\fR works, except that this
-subcommand reports all frames, like \fBsource\fRd scripts,
-\fBeval\fRs, \fBuplevel\fRs, etc.
+If \fIdepth\fR is greater than \fB0\fR it is the frame at that depth. Otherwise
+it is the number of frames up from the current frame.
.PP
-Note that for nested commands, like
+As with \fBinfo level\fR and error traces, for nested commands like
.QW "foo [bar [x]]" ,
only
.QW x
-will be seen by an \fBinfo frame\fR invoked within
+is seen by \fBinfo frame\fR invoked within
.QW x .
-This is the same as for \fBinfo level\fR and error stack traces.
.PP
-The result dictionary may contain the keys listed below, with the
-specified meanings for their values:
+The dictionary may contain the following keys:
.TP
\fBtype\fR
.
-This entry is always present and describes the nature of the location
-for the command. The recognized values are \fBsource\fR, \fBproc\fR,
+Always present. Possible values are \fBsource\fR, \fBproc\fR,
\fBeval\fR, and \fBprecompiled\fR.
.RS
.TP
\fBsource\fR\0\0\0\0\0\0\0\0
.
-means that the command is found in a script loaded by the \fBsource\fR
+A script loaded via the \fBsource\fR
command.
.TP
\fBproc\fR\0\0\0\0\0\0\0\0
.
-means that the command is found in dynamically created procedure body.
+The body of a procedure that could not be traced back to a
+line in a particular script.
.TP
\fBeval\fR\0\0\0\0\0\0\0\0
.
-means that the command is executed by \fBeval\fR or \fBuplevel\fR.
+The body of a script provided to \fBeval\fR or \fBuplevel\fR.
.TP
\fBprecompiled\fR\0\0\0\0\0\0\0\0
.
-means that the command is found in a pre-compiled script (loadable by
-the package \fBtbcload\fR), and no further information will be
-available.
+A pre-compiled 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 +220,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 +234,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 \fInterp\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 +367,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 +539,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 +701,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 +723,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 +743,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 +769,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 +779,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 9fcd055..54555e3 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 slaves. The
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..89b6909 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(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..67048ba 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
assign, element, list, multiple, set, variable
'\"Local Variables:
diff --git a/doc/library.n b/doc/library.n
index 6f8f265..4dcd598 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 d5605bc..01e0d8b 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), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(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..7219342
--- /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 TclOO
+
+\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..3179256 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), lindex(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, insert, list
diff --git a/doc/list.n b/doc/list.n
index a182fc8..3fa1975 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, quoting
'\"Local Variables:
diff --git a/doc/llength.n b/doc/llength.n
index 79f93c0..26824a0 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), lindex(n), linsert(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(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..026e9d0 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), lindex(n), linsert(n), llength(n),
+lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
foreach, iteration, list, loop, map
'\" Local Variables:
diff --git a/doc/lpop.n b/doc/lpop.n
new file mode 100644
index 0000000..631bc58
--- /dev/null
+++ b/doc/lpop.n
@@ -0,0 +1,97 @@
+'\"
+'\" Copyright (c) 2018 by 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), lindex(n), linsert(n), llength(n),
+lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(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..0d4b261 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(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..59d261b
--- /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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(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 f92792e..2e17f9c 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), 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/lreplace.n b/doc/lreplace.n
index 32b7356..bc9d7ca 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n),
+lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace
diff --git a/doc/lreverse.n b/doc/lreverse.n
index 4c2f762..2ed496a 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, reverse
'\" Local Variables:
diff --git a/doc/lsearch.n b/doc/lsearch.n
index efe1792..c5dc98f 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
binary search, linear search,
diff --git a/doc/lset.n b/doc/lset.n
index e425274..afc721f 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lsort(n)
string(n)
.SH KEYWORDS
element, index, list, replace, set
diff --git a/doc/lsort.n b/doc/lsort.n
index c3245b2..2018e30 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), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lset(n)
.SH KEYWORDS
element, list, order, sort
'\" Local Variables:
diff --git a/doc/mathfunc.n b/doc/mathfunc.n
index 7233d46..375d867 100644
--- a/doc/mathfunc.n
+++ b/doc/mathfunc.n
@@ -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 (c) 1993 The Regents of the University of California.
-Copyright (c) 1994-2000 Sun Microsystems Incorporated.
-Copyright (c) 2005, 2006 by Kevin B. Kenny <kennykb@acm.org>.
+Copyright \(co 1993 The Regents of the University of California.
+Copyright \(co 1994-2000 Sun Microsystems Incorporated.
+Copyright \(co 2005, 2006 by Kevin B. Kenny <kennykb@acm.org>.
.fi
'\" Local Variables:
'\" mode: nroff
diff --git a/doc/mathop.n b/doc/mathop.n
index 84cf308..1c70e95 100644
--- a/doc/mathop.n
+++ b/doc/mathop.n
@@ -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 2fc1eee..3d87ffd 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
@@ -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,16 +198,26 @@ 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?
.
@@ -232,6 +308,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 +529,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 +553,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 +592,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 +667,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 +681,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 +794,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..4618525 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
\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 b0b6e25..3196cac 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 db846be..8ebaed2 100644
--- a/doc/next.n
+++ b/doc/next.n
@@ -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/open.n b/doc/open.n
index 1cccc0a..b0d9781 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
.
@@ -408,7 +478,55 @@ 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 "EXAMPLE"
+.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"
.PP
Open a command pipeline and catch any errors:
.PP
@@ -419,6 +537,22 @@ if {[catch {close $fl} err]} {
puts "ls command failed: $err"
}
.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 5bd2e67..a6eee1e 100644
--- a/doc/packagens.n
+++ b/doc/packagens.n
@@ -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/re_syntax.n b/doc/re_syntax.n
index 7988071..8d732ed 100644
--- a/doc/re_syntax.n
+++ b/doc/re_syntax.n
@@ -293,12 +293,12 @@ treatment is as if the enclosing delimiters were
.QW \fB[.\fR \&
and
.QW \fB.]\fR .)
-For example, if \fBo\fR and \fB\*(qo\fR are the members of an
+For example, if \fBo\fR and \fB\[^o]\fR are the members of an
equivalence class, then
.QW \fB[[=o=]]\fR ,
-.QW \fB[[=\*(qo=]]\fR ,
+.QW \fB[[=\[^o]=]]\fR ,
and
-.QW \fB[o\*(qo]\fR \&
+.QW \fB[o\[^o]]\fR \&
are all synonymous. An equivalence class may not be an endpoint of a range.
.RS
.PP
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/self.n b/doc/self.n
index 0ad5428..855d067 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -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..568a8bd
--- /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 TclOO
+
+\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 3efdb37..823dbd5 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
diff --git a/doc/source.n b/doc/source.n
index 82fefa6..353b8fb 100644
--- a/doc/source.n
+++ b/doc/source.n
@@ -43,7 +43,7 @@ or
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
@@ -69,3 +69,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 8d8be3d..7cd53ca 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
@@ -476,7 +505,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 0e59b4f..c37eb81 100644
--- a/doc/tclsh.1
+++ b/doc/tclsh.1
@@ -143,6 +143,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/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/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/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..348557f
--- /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
+int
+\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 a Tcl result code (e.g., \fBTCL_OK\fR
+when the function is successful). 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..2d84173
--- /dev/null
+++ b/doc/zipfs.n
@@ -0,0 +1,254 @@
+'\"
+'\" 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 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 ?\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.
+.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_lex.c b/generic/regc_lex.c
index 1b00b71..a303ec6 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -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);
}
@@ -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 493f1bb..c90dd64 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -840,7 +840,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 */
@@ -1252,7 +1252,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 7f43958..7507137 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -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 219c16a..99dfef1 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -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 = VS(&functions);
+ re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
- re->re_guts = VS(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);
}
/*
@@ -512,7 +511,7 @@ freev(
struct vars *v,
int err)
{
- register int ret;
+ int ret;
if (v->re != NULL) {
rfree(v->re);
@@ -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 '(' */
}
@@ -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);
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/regerror.c b/generic/regerror.c
index f783217..500dfe2 100644
--- a/generic/regerror.c
+++ b/generic/regerror.c
@@ -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 f174420..b5f161b 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -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.
@@ -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,7 +235,7 @@ 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
@@ -268,7 +267,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));
}
/*
@@ -278,7 +277,7 @@ 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)
freeDFA(v->subdfas[i]);
@@ -299,7 +298,7 @@ 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);
+ v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, NULL);
if (ISERR())
return NULL;
}
@@ -887,7 +886,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;
diff --git a/generic/regguts.h b/generic/regguts.h
index 71d04f3..de5d18e 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 7cd3fd2..a550411 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)
}
@@ -104,7 +104,7 @@ 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 boolValue, const char *file, int line)
}
declare 23 {
@@ -119,7 +119,7 @@ declare 25 {
Tcl_Obj *Tcl_DbNewListObj(int 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 {
@@ -152,9 +152,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)
@@ -198,7 +198,7 @@ declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
int count, int objc, Tcl_Obj *const objv[])
}
-declare 49 {
+declare 49 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
}
declare 50 {
@@ -207,13 +207,13 @@ declare 50 {
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[])
}
-declare 54 {
+declare 54 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
declare 55 {
@@ -222,7 +222,7 @@ declare 55 {
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
}
-declare 57 {
+declare 57 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
}
declare 58 {
@@ -235,13 +235,13 @@ declare 59 {
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[])
}
-declare 63 {
+declare 63 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 {
@@ -250,10 +250,10 @@ declare 64 {
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int 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)
}
@@ -282,10 +282,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 {
@@ -306,7 +306,7 @@ declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
- char *Tcl_Concat(int argc, CONST84 char *const *argv)
+ char *Tcl_Concat(int argc, const char *const *argv)
}
declare 84 {
int Tcl_ConvertElement(const char *src, char *dst, int flags)
@@ -318,7 +318,7 @@ declare 85 {
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
- CONST84 char *const *argv)
+ const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
@@ -352,7 +352,7 @@ declare 93 {
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)
@@ -461,10 +461,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,7 +472,7 @@ 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 {
@@ -513,7 +513,7 @@ declare 142 {
declare 143 {
void Tcl_Finalize(void)
}
-declare 144 {
+declare 144 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_FindExecutable(const char *argv0)
}
declare 145 {
@@ -523,17 +523,17 @@ 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 *slaveCmd,
- 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 *slaveCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
@@ -558,7 +558,7 @@ 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,14 +572,14 @@ 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 *askInterp, Tcl_Interp *slaveInterp)
@@ -622,20 +622,20 @@ 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 +662,11 @@ declare 185 {
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
- char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
+ char *Tcl_JoinPath(int 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)
}
@@ -685,7 +685,7 @@ declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
declare 192 {
- char *Tcl_Merge(int argc, CONST84 char *const *argv)
+ char *Tcl_Merge(int argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
@@ -703,7 +703,7 @@ declare 196 {
}
declare 197 {
Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags)
+ const char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
@@ -729,7 +729,7 @@ 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)
@@ -765,7 +765,7 @@ declare 214 {
}
declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr, CONST84 char **endPtr)
+ const char **startPtr, const char **endPtr)
}
declare 216 {
void Tcl_Release(ClientData clientData)
@@ -779,8 +779,7 @@ declare 218 {
declare 219 {
int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
}
-# Obsolete
-declare 220 {
+declare 220 {deprecated {}} {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
@@ -813,7 +812,7 @@ declare 228 {
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
-declare 230 {
+declare 230 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
}
declare 231 {
@@ -835,43 +834,42 @@ 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 {
+declare 244 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *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)
}
@@ -892,14 +890,14 @@ 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)
}
@@ -911,7 +909,7 @@ declare 256 {
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,7 +920,7 @@ declare 259 {
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
-declare 261 {
+declare 261 {deprecated {No longer in use, changed to macro}} {
ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
@@ -944,47 +942,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 {
@@ -1058,7 +1056,7 @@ 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,
@@ -1086,7 +1084,7 @@ 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)
@@ -1147,22 +1145,22 @@ declare 319 {
Tcl_QueuePosition position)
}
declare 320 {
- Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
+ int Tcl_UniCharAtIndex(const char *src, int 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)
}
declare 325 {
- CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
+ const char *Tcl_UtfAtIndex(const char *src, int index)
}
declare 326 {
int Tcl_UtfCharComplete(const char *src, int length)
@@ -1171,16 +1169,16 @@ declare 327 {
int 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 *Tcl_UtfNext(const char *src)
}
declare 331 {
- CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
+ const char *Tcl_UtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
@@ -1199,7 +1197,7 @@ declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
- int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr)
+ int Tcl_UtfToChar16(const char *src, unsigned short *chPtr)
}
declare 337 {
int Tcl_UtfToUpper(char *src)
@@ -1213,10 +1211,10 @@ declare 339 {
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 {
@@ -1246,26 +1244,26 @@ declare 350 {
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
-declare 352 {
+declare 352 {deprecated {Use Tcl_GetCharLength}} {
int Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
-declare 353 {
+declare 353 {deprecated {Use Tcl_UtfNcmp}} {
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
declare 354 {
- char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
+ char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
int uniLength, Tcl_DString *dsPtr)
}
declare 355 {
- Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src,
+ unsigned short *Tcl_UtfToChar16DString(const char *src,
int 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)
}
@@ -1278,7 +1276,7 @@ declare 359 {
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes,
- Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
+ Tcl_Parse *parsePtr, int append, const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes,
@@ -1291,7 +1289,7 @@ declare 362 {
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ const char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes,
@@ -1350,15 +1348,15 @@ declare 380 {
int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
- Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
+ int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
-declare 382 {
+declare 382 {deprecated {No longer in use, changed to macro}} {
Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
-declare 384 {
+declare 384 {deprecated {Use Tcl_AppendStringsToObj}} {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int length)
}
@@ -1407,7 +1405,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(
@@ -1417,7 +1415,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)
}
@@ -1433,7 +1431,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)
}
@@ -1484,11 +1482,11 @@ declare 417 {
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
-declare 419 {
+declare 419 {deprecated {Use Tcl_UtfNcasecmp}} {
int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
-declare 420 {
+declare 420 {deprecated {Use Tcl_StringCaseMatch}} {
int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
const Tcl_UniChar *uniPattern, int nocase)
}
@@ -1547,12 +1545,12 @@ declare 434 {
}
# 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)
}
-declare 436 {
+declare 436 {deprecated {}} {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
@@ -1870,7 +1868,7 @@ 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)
}
@@ -2011,19 +2009,19 @@ 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
@@ -2052,7 +2050,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
@@ -2325,10 +2323,87 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
-declare 649 {
- void TclUnusedStubEntry(void)
+# TIP #456
+declare 631 {
+ Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
+ const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc,
+ ClientData 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_FreeIntRep(Tcl_Obj *objPtr)
+}
+declare 637 {
+ char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ unsigned int numBytes)
+}
+declare 638 {
+ Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr)
+}
+declare 639 {
+ void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr,
+ const Tcl_ObjIntRep *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, int size)
+}
+
+declare 645 {
+ int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int endValue, int *indexPtr)
}
+# TIP #548
+declare 646 {
+ int Tcl_UtfToUniChar(const char *src, int *chPtr)
+}
+declare 647 {
+ char *Tcl_UniCharToUtfDString(const int *uniStr,
+ int uniLength, Tcl_DString *dsPtr)
+}
+declare 648 {
+ int *Tcl_UtfToUniCharDString(const char *src,
+ int length, Tcl_DString *dsPtr)
+}
+
+# ----- BASELINE -- FOR -- 8.7.0 ----- #
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
@@ -2378,6 +2453,19 @@ export {
Tcl_Interp *interp)
}
export {
+ void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
+ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+}
+export {
+ void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+}
+export {
+ Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
+}
+export {
+ void Tcl_FindExecutable(const char *argv0)
+}
+export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
}
@@ -2392,6 +2480,9 @@ export {
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
+export {
+ void Tcl_InitSubsystems(void)
+}
# Local Variables:
# mode: tcl
diff --git a/generic/tcl.h b/generic/tcl.h
index 458072a..02ef01e 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -38,8 +38,8 @@ 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
@@ -49,13 +49,14 @@ extern "C" {
*/
#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 6
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 10
+#define TCL_MINOR_VERSION 7
+#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE
+#define TCL_RELEASE_SERIAL 4
-#define TCL_VERSION "8.6"
-#define TCL_PATCH_LEVEL "8.6.10"
+#define TCL_VERSION "8.7"
+#define TCL_PATCH_LEVEL "8.7a4"
+#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED)
/*
*----------------------------------------------------------------------------
* The following definitions set up the proper options for Windows compilers.
@@ -85,6 +86,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 +103,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
@@ -131,14 +132,15 @@ extern "C" {
*/
#include <stdarg.h>
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# 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)
-#endif
+#endif /* !TCL_NO_DEPRECATED */
#if defined(__GNUC__) && (__GNUC__ > 2)
# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b)))
# define TCL_NORETURN __attribute__ ((noreturn))
+# define TCL_NOINLINE __attribute__ ((noinline))
# if defined(BUILD_tcl) || defined(BUILD_tk)
# define TCL_NORETURN1 __attribute__ ((noreturn))
# else
@@ -148,8 +150,10 @@ extern "C" {
# define TCL_FORMAT_PRINTF(a,b)
# if defined(_MSC_VER) && (_MSC_VER >= 1310)
# 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
@@ -216,7 +220,7 @@ extern "C" {
* to be included in a shared library, then it should have the DLLEXPORT
* storage class. If is being declared for use by a module that is going to
* link against the shared library, then it should have the DLLIMPORT storage
- * class. If the symbol is beind declared for a static build or for use from a
+ * class. If the symbol is being declared for a static build or for use from a
* stub library, then the storage class should be empty.
*
* The convention is that a macro called BUILD_xxxx, where xxxx is the name of
@@ -245,10 +249,9 @@ extern "C" {
* New code should use prototypes.
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# undef _ANSI_ARGS_
# define _ANSI_ARGS_(x) x
-#endif
/*
* Definitions that allow this header file to be used either with or without
@@ -258,34 +261,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
/*
@@ -309,6 +292,7 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
@@ -324,23 +308,16 @@ typedef long LONG;
*/
#ifndef __VXWORKS__
-# ifndef NO_VOID
-# define VOID void
-# else
-# define VOID char
-# endif
+# define VOID void
#endif
+#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */
/*
* Miscellaneous declarations.
*/
#ifndef _CLIENTDATA
-# ifndef NO_VOID
- typedef void *ClientData;
-# else
- typedef int *ClientData;
-# endif
+ typedef void *ClientData;
# define _CLIENTDATA
#endif
@@ -384,58 +361,47 @@ typedef long LONG;
*/
#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
-# if defined(_WIN32)
+# if defined(_MSC_VER) || defined(_WIN32)
# define TCL_WIDE_INT_TYPE __int64
-# ifdef __BORLANDC__
-# define TCL_LL_MODIFIER "L"
-# else /* __BORLANDC__ */
-# define TCL_LL_MODIFIER "I64"
-# endif /* __BORLANDC__ */
+# define TCL_LL_MODIFIER "I64"
+# if defined(_WIN64)
+# define TCL_Z_MODIFIER "I"
+# endif
# elif defined(__GNUC__)
-# define TCL_WIDE_INT_TYPE long long
-# define TCL_LL_MODIFIER "ll"
+# define TCL_Z_MODIFIER "z"
# else /* ! _WIN32 && ! __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)
+# if defined(LLONG_MAX) && (LLONG_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 */
+
+#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
+# define TCL_LL_MODIFIER "ll"
+#endif /* !TCL_LL_MODIFIER */
+#ifndef TCL_Z_MODIFIER
+# if defined(__GNUC__) && !defined(_WIN32)
+# define TCL_Z_MODIFIER "z"
+# else
+# define TCL_Z_MODIFIER ""
+# endif
+#endif /* !TCL_Z_MODIFIER */
+#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
+#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
+#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
+#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#if defined(_WIN32)
# ifdef __BORLANDC__
@@ -491,37 +457,15 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
*/
typedef struct Tcl_Interp
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{
/* 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 */
+#endif /* !TCL_NO_DEPRECATED */
Tcl_Interp;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
@@ -671,7 +615,9 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_BREAK 3
#define TCL_CONTINUE 4
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_RESULT_SIZE 200
+#endif
/*
*----------------------------------------------------------------------------
@@ -687,6 +633,7 @@ typedef struct stat *Tcl_OldStat_;
* Argument descriptors for math function callbacks in expressions:
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
@@ -698,6 +645,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
@@ -718,10 +669,10 @@ 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[]);
+ int argc, const char *argv[]);
typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *proc,
- ClientData cmdClientData, int argc, CONST84 char *argv[]);
+ ClientData cmdClientData, int argc, const char *argv[]);
typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, const char *command, Tcl_Command commandInfo, int objc,
struct Tcl_Obj *const *objv);
@@ -758,7 +709,7 @@ typedef void (Tcl_TimerProc) (ClientData 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);
+ const char *part1, const char *part2, int flags);
typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp,
const char *oldName, const char *newName, int flags);
typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc,
@@ -796,6 +747,29 @@ typedef struct Tcl_ObjType {
} Tcl_ObjType;
/*
+ * The following structure stores an internal representation (intrep) for
+ * a Tcl value. An intrep 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 intrep.
+ */
+
+typedef union Tcl_ObjIntRep { /* 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_ObjIntRep;
+
+/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
@@ -820,39 +794,9 @@ typedef struct Tcl_Obj {
* 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_ObjIntRep 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);
/*
*----------------------------------------------------------------------------
@@ -868,7 +812,7 @@ typedef struct Tcl_SavedResult {
char *appendResult;
int appendAvl;
int appendUsed;
- char resultSpace[TCL_RESULT_SIZE+1];
+ char resultSpace[200+1];
} Tcl_SavedResult;
/*
@@ -994,7 +938,9 @@ typedef struct Tcl_DString {
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
-#define Tcl_DStringTrunc Tcl_DStringSetLength
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# define Tcl_DStringTrunc Tcl_DStringSetLength
+#endif /* !TCL_NO_DEPRECATED */
/*
* Definitions for the maximum number of digits of precision that may be
@@ -1085,7 +1031,11 @@ typedef struct Tcl_DString {
#define TCL_TRACE_WRITES 0x20
#define TCL_TRACE_UNSETS 0x40
#define TCL_TRACE_DESTROYED 0x80
+
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_INTERP_DESTROYED 0x100
+#endif
+
#define TCL_LEAVE_ERR_MSG 0x200
#define TCL_TRACE_ARRAY 0x800
#ifndef TCL_REMOVE_OBSOLETE_TRACES
@@ -1120,9 +1070,9 @@ typedef struct Tcl_DString {
* give the flag)
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define TCL_PARSE_PART1 0x400
-#endif
+#endif /* !TCL_NO_DEPRECATED */
/*
* Types for linked variables:
@@ -1138,10 +1088,17 @@ 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
/*
@@ -1149,29 +1106,21 @@ typedef struct Tcl_DString {
* Forward declarations of Tcl_HashTable and related types.
*/
+#ifndef TCL_HASH_TYPE
+# define TCL_HASH_TYPE unsigned
+#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.
*/
@@ -1180,15 +1129,9 @@ 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
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
@@ -1348,8 +1291,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. */
+ unsigned int epoch; /* Epoch marker for dictionary being searched,
+ * or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
@@ -1457,10 +1400,12 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
* 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)
/*
@@ -1482,14 +1427,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData,
typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf,
int toRead, int *errorCodePtr);
typedef int (Tcl_DriverOutputProc) (ClientData instanceData,
- CONST84 char *buf, int toWrite, int *errorCodePtr);
+ const char *buf, int toWrite, int *errorCodePtr);
typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset,
int mode, int *errorCodePtr);
typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData,
- Tcl_Interp *interp, CONST84 char *optionName,
+ Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask);
typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData,
@@ -1529,7 +1474,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. */
@@ -1714,7 +1659,7 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
* struct Tcl_Filesystem:
*
* One such structure exists for each type (kind) of filesystem. It collects
- * together in one place all the functions that are part of the specific
+ * together the functions that form the interface for a particulr the
* filesystem. Tcl always accesses the filesystem through one of these
* structures.
*
@@ -1729,147 +1674,119 @@ typedef struct Tcl_Filesystem {
* compatibility can be assured. */
Tcl_FSVersion version; /* Version of the filesystem type. */
Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
- /* Function to check whether a path is in this
+ /* Determines whether the pathname is in this
* filesystem. This is the most important
* filesystem function. */
Tcl_FSDupInternalRepProc *dupInternalRepProc;
- /* Function to duplicate internal fs rep. May
- * be NULL (but then fs is less efficient). */
+ /* Duplicates the internal handle of the node.
+ * If it is NULL, the filesystem is less
+ * performant. */
Tcl_FSFreeInternalRepProc *freeInternalRepProc;
- /* Function to free internal fs rep. Must be
- * implemented if internal representations
- * need freeing, otherwise it can be NULL. */
+ /* Frees the internal handle of the node. NULL
+ * only if there is no need to free resources
+ * used for the internal handle. */
Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
- /* Function to convert internal representation
- * to a normalized path. Only required if the
- * fs creates pure path objects with no
- * string/path representation. */
+ /* Converts the internal handle to a normalized
+ * path. NULL if the filesystem creates nodes
+ * having no pathname. */
Tcl_FSCreateInternalRepProc *createInternalRepProc;
- /* Function to create a filesystem-specific
- * internal representation. May be NULL if
- * paths have no internal representation, or
- * if the Tcl_FSPathInFilesystemProc for this
- * filesystem always immediately creates an
- * internal representation for paths it
- * accepts. */
+ /* Creates an internal handle for a pathname.
+ * May be NULL if pathnames have no internal
+ * handle or if pathInFilesystemProc always
+ * immediately creates an internal
+ * representation for pathnames in the
+ * filesystem. */
Tcl_FSNormalizePathProc *normalizePathProc;
- /* Function to normalize a path. Should be
- * implemented for all filesystems which can
- * have multiple string representations for
- * the same path object. */
+ /* Normalizes a path. Should be implemented if
+ * the filesystems supports multiple paths to
+ * the same node. */
Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
- /* Function to determine the type of a path in
- * this filesystem. May be NULL. */
+ /* Determines the type of a path in this
+ * filesystem. May be NULL. */
Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
- /* Function to return the separator
- * character(s) for this filesystem. Must be
- * implemented. */
- Tcl_FSStatProc *statProc; /* Function to process a 'Tcl_FSStat()' call.
- * Must be implemented for any reasonable
- * filesystem. */
- Tcl_FSAccessProc *accessProc;
- /* Function to process a 'Tcl_FSAccess()'
- * call. Must be implemented for any
+ /* Produces the separator character(s) for this
+ * filesystem. Must not be NULL. */
+ Tcl_FSStatProc *statProc; /* Called by 'Tcl_FSStat()'. Provided by any
* reasonable filesystem. */
+ Tcl_FSAccessProc *accessProc;
+ /* Called by 'Tcl_FSAccess()'. Implemented by
+ * any reasonable filesystem. */
Tcl_FSOpenFileChannelProc *openFileChannelProc;
- /* Function to process a
- * 'Tcl_FSOpenFileChannel()' call. Must be
- * implemented for any reasonable
- * filesystem. */
+ /* Called by 'Tcl_FSOpenFileChannel()'.
+ * Provided by any reasonable filesystem. */
Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
- /* Function to process a
- * 'Tcl_FSMatchInDirectory()'. If not
- * implemented, then glob and recursive copy
- * functionality will be lacking in the
- * filesystem. */
- Tcl_FSUtimeProc *utimeProc; /* Function to process a 'Tcl_FSUtime()' call.
- * Required to allow setting (not reading) of
- * times with 'file mtime', 'file atime' and
- * the open-r/open-w/fcopy implementation of
- * 'file copy'. */
- Tcl_FSLinkProc *linkProc; /* Function to process a 'Tcl_FSLink()' call.
- * Should be implemented only if the
- * filesystem supports links (reading or
- * creating). */
+ /* Called by 'Tcl_FSMatchInDirectory()'. NULL
+ * if the filesystem does not support glob or
+ * recursive copy. */
+ Tcl_FSUtimeProc *utimeProc; /* Called by 'Tcl_FSUtime()', by 'file
+ * mtime' to set (not read) times, 'file
+ * atime', and the open-r/open-w/fcopy variant
+ * of 'file copy'. */
+ Tcl_FSLinkProc *linkProc; /* Called by 'Tcl_FSLink()'. NULL if reading or
+ * creating links is not supported. */
Tcl_FSListVolumesProc *listVolumesProc;
- /* Function to list any filesystem volumes
- * added by this filesystem. Should be
- * implemented only if the filesystem adds
- * volumes at the head of the filesystem. */
+ /* Lists filesystem volumes added by this
+ * filesystem. NULL if the filesystem does not
+ * use volumes. */
Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
- /* Function to list all attributes strings
- * which are valid for this filesystem. If not
- * implemented the filesystem will not support
- * the 'file attributes' command. This allows
- * arbitrary additional information to be
- * attached to files in the filesystem. */
+ /* List all valid attributes strings. NULL if
+ * the filesystem does not support the 'file
+ * attributes' command. Can be used to attach
+ * arbitrary additional data to files in a
+ * filesystem. */
Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
- /* Function to process a
- * 'Tcl_FSFileAttrsGet()' call, used by 'file
- * attributes'. */
+ /* Called by 'Tcl_FSFileAttrsGet()' and by
+ * 'file attributes'. */
Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
- /* Function to process a
- * 'Tcl_FSFileAttrsSet()' call, used by 'file
- * attributes'. */
+ /* Called by 'Tcl_FSFileAttrsSet()' and by
+ * 'file attributes'. */
Tcl_FSCreateDirectoryProc *createDirectoryProc;
- /* Function to process a
- * 'Tcl_FSCreateDirectory()' call. Should be
- * implemented unless the FS is read-only. */
+ /* Called by 'Tcl_FSCreateDirectory()'. May be
+ * NULL if the filesystem is read-only. */
Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
- /* Function to process a
- * 'Tcl_FSRemoveDirectory()' call. Should be
- * implemented unless the FS is read-only. */
+ /* Called by 'Tcl_FSRemoveDirectory()'. May be
+ * NULL if the filesystem is read-only. */
Tcl_FSDeleteFileProc *deleteFileProc;
- /* Function to process a 'Tcl_FSDeleteFile()'
- * call. Should be implemented unless the FS
- * is read-only. */
+ /* Called by 'Tcl_FSDeleteFile()' May be NULL
+ * if the filesystem is is read-only. */
Tcl_FSCopyFileProc *copyFileProc;
- /* Function to process a 'Tcl_FSCopyFile()'
- * call. If not implemented Tcl will fall back
- * on open-r, open-w and fcopy as a copying
- * mechanism, for copying actions initiated in
- * Tcl (not C). */
+ /* Called by 'Tcl_FSCopyFile()'. If NULL, for
+ * a copy operation at the script level (not
+ * C) Tcl uses open-r, open-w and fcopy. */
Tcl_FSRenameFileProc *renameFileProc;
- /* Function to process a 'Tcl_FSRenameFile()'
- * call. If not implemented, Tcl will fall
- * back on a copy and delete mechanism, for
- * rename actions initiated in Tcl (not C). */
+ /* Called by 'Tcl_FSRenameFile()'. If NULL, for
+ * a rename operation at the script level (not
+ * C) Tcl performs a copy operation followed
+ * by a delete operation. */
Tcl_FSCopyDirectoryProc *copyDirectoryProc;
- /* Function to process a
- * 'Tcl_FSCopyDirectory()' call. If not
- * implemented, Tcl will fall back on a
- * recursive create-dir, file copy mechanism,
- * for copying actions initiated in Tcl (not
- * C). */
- Tcl_FSLstatProc *lstatProc; /* Function to process a 'Tcl_FSLstat()' call.
- * If not implemented, Tcl will attempt to use
- * the 'statProc' defined above instead. */
+ /* Called by 'Tcl_FSCopyDirectory()'. If NULL,
+ * for a copy operation at the script level
+ * (not C) Tcl recursively creates directories
+ * and copies files. */
+ Tcl_FSLstatProc *lstatProc; /* Called by 'Tcl_FSLstat()'. If NULL, Tcl
+ * attempts to use 'statProc' instead. */
Tcl_FSLoadFileProc *loadFileProc;
- /* Function to process a 'Tcl_FSLoadFile()'
- * call. If not implemented, Tcl will fall
- * back on a copy to native-temp followed by a
- * Tcl_FSLoadFile on that temporary copy. */
+ /* Called by 'Tcl_FSLoadFile()'. If NULL, Tcl
+ * performs a copy to a temporary file in the
+ * native filesystem and then calls
+ * Tcl_FSLoadFile() on that temporary copy. */
Tcl_FSGetCwdProc *getCwdProc;
- /* Function to process a 'Tcl_FSGetCwd()'
- * call. Most filesystems need not implement
- * this. It will usually only be called once,
- * if 'getcwd' is called before 'chdir'. May
- * be NULL. */
- Tcl_FSChdirProc *chdirProc; /* Function to process a 'Tcl_FSChdir()' call.
- * If filesystems do not implement this, it
- * will be emulated by a series of directory
- * access checks. Otherwise, virtual
- * filesystems which do implement it need only
- * respond with a positive return result if
- * the dirName is a valid directory in their
- * filesystem. They need not remember the
- * result, since that will be automatically
- * remembered for use by GetCwd. Real
- * filesystems should carry out the correct
- * action (i.e. call the correct system
- * 'chdir' api). If not implemented, then 'cd'
- * and 'pwd' will fail inside the
- * filesystem. */
+ /* Called by 'Tcl_FSGetCwd()'. Normally NULL.
+ * Usually only called once: If 'getcwd' is
+ * called before 'chdir' is ever called. */
+ Tcl_FSChdirProc *chdirProc; /* Called by 'Tcl_FSChdir()'. For a virtual
+ * filesystem, chdirProc just returns zero
+ * (success) if the pathname is a valid
+ * directory, and some other value otherwise.
+ * For A real filesystem, chdirProc performs
+ * the correct action, e.g. calls the system
+ * 'chdir' function. If not implemented, then
+ * 'cd' and 'pwd' fail for a pathname in this
+ * filesystem. On success Tcl stores the
+ * pathname for use by GetCwd. If NULL, Tcl
+ * performs records the pathname as the new
+ * current directory if it passes a series of
+ * directory access checks. */
} Tcl_Filesystem;
/*
@@ -2130,29 +2047,28 @@ typedef struct Tcl_EncodingType {
* reset to an initial state. If the source
* buffer contains the entire input stream to be
* converted, this flag should be set.
- * TCL_ENCODING_STOPONERROR - If set, then the converter will return
- * immediately upon encountering an invalid byte
- * sequence or a source character that has no
- * mapping in the target encoding. If clear, then
- * the converter will skip the problem,
- * substituting one or more "close" characters in
- * the destination buffer and then continue to
+ * TCL_ENCODING_STOPONERROR - If set, the converter returns immediately upon
+ * 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
+ * one or more "close" characters in the
+ * destination buffer and then continues to
* convert the source.
- * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf will not append a
- * terminating NUL byte. Knowing that it will
- * not need space to do so, it will fill all
- * dstLen bytes with encoded UTF-8 content, as
- * other circumstances permit. If clear, the
- * default behavior is to reserve a byte in
- * the dst space for NUL termination, and to
- * append the NUL byte.
+ * 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
+ * all dstLen bytes with encoded UTF-8 content if
+ * needed. If clear, a byte is reserved in the
+ * dst space for NUL termination, and a
+ * terminating NUL is appended.
* TCL_ENCODING_CHAR_LIMIT - If set and dstCharsPtr is not NULL, then
- * Tcl_ExternalToUtf takes the initial value
- * of *dstCharsPtr is taken as a limit of the
- * maximum number of chars to produce in the
- * encoded UTF-8 content. Otherwise, the
- * number of chars produced is controlled only
- * by other limiting factors.
+ * Tcl_ExternalToUtf takes the initial value of
+ * *dstCharsPtr as a limit of the maximum number
+ * of chars to produce in the encoded UTF-8
+ * content. Otherwise, the number of chars
+ * produced is controlled only by other limiting
+ * factors.
*/
#define TCL_ENCODING_START 0x01
@@ -2196,12 +2112,11 @@ 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
@@ -2213,17 +2128,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
- * (perhaps wchar_t). 64-bit systems may have troubles. The size of this
- * value must be reflected correctly in regcustom.h and
- * in tclEncoding.c.
- * 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 wchar_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
@@ -2258,15 +2169,24 @@ typedef struct Tcl_Config {
typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp);
typedef void (Tcl_LimitHandlerDeleteProc) (ClientData 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
/*
*----------------------------------------------------------------------------
@@ -2377,6 +2297,21 @@ 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 int-typed values, see TIP #494
+ */
+
+#define TCL_IO_FAILURE (-1)
+#define TCL_AUTO_LENGTH (-1)
+#define TCL_INDEX_NONE (-1)
+
+/*
+ *----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
@@ -2387,9 +2322,6 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables.
- *
- * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
- * value since the stubs tables don't match.
*/
#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
@@ -2402,22 +2334,38 @@ 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);
-
-/*
- * When not using stubs, make it a macro.
- */
-
-#ifndef USE_TCL_STUBS
-#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgInitStubsCheck(interp, version, exact)
+#if defined(_WIN32)
+ TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
+#else
+# define Tcl_ConsolePanic ((Tcl_PanicProc *)0)
#endif
-/*
- * TODO - tommath stubs export goes here!
- */
+#ifdef USE_TCL_STUBS
+#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+# 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, \
+ 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+#endif
+#else
+#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+#else
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \
+ 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+#endif
+#endif
/*
* Public functions that are not accessible via the stubs table.
@@ -2425,12 +2373,18 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
*/
#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
- ((Tcl_CreateInterp)()))
+ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)()))
EXTERN void Tcl_MainEx(int argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
+EXTERN void Tcl_InitSubsystems(void);
EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
+#ifdef _WIN32
+EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv);
+#else
+EXTERN int TclZipfs_AppHook(int *argc, char ***argv);
+#endif
/*
*----------------------------------------------------------------------------
@@ -2501,19 +2455,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.
* http://c2.com/cgi/wiki?TrivialDoWhileLoop
*/
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
@@ -2521,6 +2480,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
TclFreeObj(_objPtr); \
} \
} while(0)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
@@ -2537,22 +2497,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__)
@@ -2591,31 +2545,10 @@ 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:
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibility.
@@ -2630,7 +2563,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# define panic Tcl_Panic
#endif
# define panicVA Tcl_PanicVA
-#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------------
@@ -2641,6 +2573,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 6187ce2..bc4716d 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -22,7 +22,7 @@
*/
#include "tclInt.h"
-#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)
+#if !TCL_THREADS || !defined(USE_THREAD_ALLOC)
#if USE_TCLALLOC
@@ -32,7 +32,7 @@
*/
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
-typedef unsigned long caddr_t;
+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;
@@ -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,13 +249,13 @@ TclFinalizeAllocSubsystem(void)
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
- register union overhead *overPtr;
- register long bucket;
- register unsigned amount;
+ union overhead *overPtr;
+ size_t bucket;
+ unsigned amount;
struct block *bigBlockPtr = NULL;
if (!allocInit) {
@@ -274,8 +274,8 @@ TclpAlloc(
if (numBytes >= MAXMALLOC - OVERHEAD) {
if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) {
- bigBlockPtr = (struct block *) TclpSysAlloc((unsigned)
- (sizeof(struct block) + OVERHEAD + numBytes), 0);
+ bigBlockPtr = (struct block *) TclpSysAlloc(
+ 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) /* What bucket to allocat to. */
+ size_t bucket) /* What bucket to allocate to. */
{
- register union overhead *overPtr;
- register long size; /* size of desired block */
- long amount; /* amount to allocate */
- int numBlocks; /* how many blocks we get */
+ union overhead *overPtr;
+ 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,14 +398,14 @@ MoreCore(
* VAX, I think) or for a negative arg.
*/
- size = 1 << (bucket + 3);
+ size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
- blockPtr = (struct block *) TclpSysAlloc((unsigned)
+ blockPtr = (struct block *) TclpSysAlloc(
(sizeof(struct block) + amount), 1);
/* no more room! */
if (blockPtr == NULL) {
@@ -446,10 +446,10 @@ MoreCore(
void
TclpFree(
- char *oldPtr) /* Pointer to memory to free. */
+ void *oldPtr) /* Pointer to memory to free. */
{
- register long size;
- register union overhead *overPtr;
+ size_t size;
+ union overhead *overPtr;
struct block *bigBlockPtr;
if (oldPtr == NULL) {
@@ -509,16 +509,16 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *oldPtr, /* Pointer to alloced block. */
+ void *oldPtr, /* Pointer to alloced 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,7 +581,7 @@ TclpRealloc(
#endif
Tcl_MutexUnlock(allocMutexPtr);
- return (char *)(overPtr+1);
+ return (void *)(overPtr+1);
}
maxSize = 1 << (i+3);
expensive = 0;
@@ -604,7 +604,7 @@ TclpRealloc(
if (maxSize < numBytes) {
numBytes = maxSize;
}
- memcpy(newPtr, oldPtr, (size_t) numBytes);
+ memcpy(newPtr, oldPtr, numBytes);
TclpFree(oldPtr);
return newPtr;
}
@@ -645,29 +645,29 @@ void
mstats(
char *s) /* Where to write info. */
{
- register int i, j;
- register union overhead *overPtr;
- int totalFree = 0, totalUsed = 0;
+ unsigned int i, j;
+ union overhead *overPtr;
+ 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) * (1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %d", numMallocs[i]);
+ fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]);
totalUsed += numMallocs[i] * (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 (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n",
MAXMALLOC, numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
@@ -692,11 +692,11 @@ mstats(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
- return (char *) malloc(numBytes);
+ return malloc(numBytes);
}
/*
@@ -717,7 +717,7 @@ TclpAlloc(
void
TclpFree(
- char *oldPtr) /* Pointer to memory to free. */
+ void *oldPtr) /* Pointer to memory to free. */
{
free(oldPtr);
return;
@@ -739,12 +739,12 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *oldPtr, /* Pointer to alloced block. */
+ void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
- return (char *) realloc(oldPtr, numBytes);
+ return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index d154bcf..9e5e947 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -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.
@@ -144,6 +145,8 @@ typedef enum TalInstType {
* 1 */
ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1
* operands, produces 1, N > 0 */
+ ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2
+ * operands, produces 1, N > 0 */
ASSEM_DICT_SET, /* specifies key count and LVT index, consumes
* N+1 operands, produces 1, N > 0 */
ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes
@@ -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},
@@ -497,7 +505,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
{"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0},
{"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
- {NULL, 0, 0, 0, 0}
+ {NULL, ASSEM_1BYTE, 0, 0, 0}
};
/*
@@ -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;
@@ -803,7 +815,7 @@ TclNRAssembleObjCmd(
Tcl_AddErrorInfo(interp, "\n (\"");
Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
- backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp));
+ backtrace = Tcl_NewWideIntObj(Tcl_GetErrorLine(interp));
Tcl_AppendObjToErrorInfo(interp, backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
@@ -840,7 +852,7 @@ CompileAssembleObj(
Interp *iPtr = (Interp *) interp;
/* Internals of the interpreter */
CompileEnv compEnv; /* Compilation environment structure */
- register ByteCode *codePtr = NULL;
+ ByteCode *codePtr = NULL;
/* Bytecode resulting from the assembly */
Namespace* namespacePtr; /* Namespace in which variable and command
* names in the bytecode resolve */
@@ -848,15 +860,15 @@ CompileAssembleObj(
const char* source; /* String representation of the source code */
int sourceLen; /* Length of the source code in bytes */
-
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &assembleCodeType) {
+ ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr);
+
+ if (codePtr) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -870,7 +882,7 @@ CompileAssembleObj(
* Not valid, so free it and regenerate.
*/
- FreeAssembleCodeInternalRep(objPtr);
+ Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL);
}
/*
@@ -895,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 = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -950,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
@@ -959,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.
*/
@@ -1144,9 +1152,9 @@ NewAssemblyEnv(
{
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
- AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv));
+ AssemblyEnv* assemEnvPtr = (AssemblyEnv*)TclStackAlloc(interp, sizeof(AssemblyEnv));
/* Assembler environment under construction */
- Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse* parsePtr = (Tcl_Parse*)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Parse of one line of assembly code */
assemEnvPtr->envPtr = envPtr;
@@ -1305,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;
@@ -1398,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;
@@ -1471,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!
@@ -1534,7 +1543,7 @@ AssembleOneLine(
goto cleanup;
}
- jtPtr = ckalloc(sizeof(JumptableInfo));
+ jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
@@ -1566,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;
@@ -1743,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;
@@ -1928,7 +1937,7 @@ MoveExceptionRangesToBasicBlock(
curr_bb->foreignExceptionBase = savedExceptArrayNext;
curr_bb->foreignExceptionCount = exceptionCount;
curr_bb->foreignExceptions =
- ckalloc(exceptionCount * sizeof(ExceptionRange));
+ (ExceptionRange*)ckalloc(exceptionCount * sizeof(ExceptionRange));
memcpy(curr_bb->foreignExceptions,
envPtr->exceptArrayPtr + savedExceptArrayNext,
exceptionCount * sizeof(ExceptionRange));
@@ -1993,7 +2002,7 @@ CreateMirrorJumpTable(
* Allocate the jumptable.
*/
- jtPtr = ckalloc(sizeof(JumptableInfo));
+ jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo));
jtHashPtr = &jtPtr->hashTable;
Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
@@ -2003,15 +2012,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;
@@ -2053,7 +2062,7 @@ DeleteMirrorJumpTable(
for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
- label = Tcl_GetHashValue(entry);
+ label = (Tcl_Obj*)Tcl_GetHashValue(entry);
Tcl_DecrRefCount(label);
Tcl_SetHashValue(entry, NULL);
}
@@ -2259,7 +2268,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 +2316,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;
@@ -2641,7 +2650,7 @@ AllocBB(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
- BasicBlock *bb = ckalloc(sizeof(BasicBlock));
+ BasicBlock *bb = (BasicBlock*)ckalloc(sizeof(BasicBlock));
bb->originalStartOffset =
bb->startOffset = envPtr->codeNext - envPtr->codeStart;
@@ -2820,7 +2829,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);
@@ -2832,7 +2841,7 @@ CalculateJumpRelocations(
* target is out of range.
*/
- jumpTarget = Tcl_GetHashValue(entry);
+ jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
@@ -2899,12 +2908,12 @@ CheckJumpTableLabels(
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
- symbolObj = Tcl_GetHashValue(symEntryPtr);
+ 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 +2951,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,8 +3036,8 @@ FillInJumpOffsets(
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
- jumpTarget = Tcl_GetHashValue(entry);
+ TclGetString(bbPtr->jumpTarget));
+ jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
if (bbPtr->flags & BB_JUMP1) {
@@ -3087,7 +3096,7 @@ ResolveJumpTableTargets(
auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex);
- realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex);
+ realJumpTablePtr = (JumptableInfo*)TclFetchAuxData(envPtr, auxDataIndex);
realJumpHashPtr = &realJumpTablePtr->hashTable;
/*
@@ -3098,18 +3107,18 @@ ResolveJumpTableTargets(
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
- symbolObj = Tcl_GetHashValue(symEntryPtr);
- DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
+ symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
+ DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
- jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr);
+ 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,8 +3490,8 @@ StackCheckBasicBlock(
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(blockPtr->jumpTarget));
- jumpTarget = Tcl_GetHashValue(entry);
+ TclGetString(blockPtr->jumpTarget));
+ jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
}
@@ -3496,10 +3505,10 @@ StackCheckBasicBlock(
&jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
- targetLabel = Tcl_GetHashValue(jtEntry);
+ targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
- jumpTarget = Tcl_GetHashValue(entry);
+ TclGetString(targetLabel));
+ jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
}
@@ -3560,7 +3569,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,8 +3812,8 @@ ProcessCatchesInBasicBlock(
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
- jumpTarget = Tcl_GetHashValue(entry);
+ TclGetString(bbPtr->jumpTarget));
+ jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
}
@@ -3817,10 +3826,10 @@ ProcessCatchesInBasicBlock(
for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
- targetLabel = Tcl_GetHashValue(jtEntry);
+ targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
- jumpTarget = Tcl_GetHashValue(entry);
+ TclGetString(targetLabel));
+ jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
}
@@ -3919,8 +3928,8 @@ BuildExceptionRanges(
* Allocate memory for a stack of active catches.
*/
- catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*));
- catchIndices = ckalloc(maxCatchDepth * sizeof(int));
+ catches = (BasicBlock**)ckalloc(maxCatchDepth * sizeof(BasicBlock*));
+ catchIndices = (int *)ckalloc(maxCatchDepth * sizeof(int));
for (i = 0; i < maxCatchDepth; ++i) {
catches[i] = NULL;
catchIndices[i] = -1;
@@ -3988,7 +3997,7 @@ UnstackExpiredCatches(
* corresponding to the catch contexts */
{
ExceptionRange* range; /* Exception range for a specific catch */
- BasicBlock* catch; /* Catch block being examined */
+ BasicBlock* block; /* Catch block being examined */
BasicBlockCatchState catchState;
/* State of the code relative to the catch
* block being examined ("in catch" or
@@ -4016,18 +4025,18 @@ UnstackExpiredCatches(
*/
catchState = bbPtr->catchState;
- catch = bbPtr->enclosingCatch;
+ block = bbPtr->enclosingCatch;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != NULL) {
- if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) {
+ if (catches[catchDepth] != block || catchState >= BBCS_CAUGHT) {
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
catches[catchDepth] = NULL;
catchIndices[catchDepth] = -1;
}
- catchState = catch->catchState;
- catch = catch->enclosingCatch;
+ catchState = block->catchState;
+ block = block->enclosingCatch;
}
}
}
@@ -4056,19 +4065,19 @@ LookForFreshCatches(
BasicBlockCatchState catchState;
/* State ("in catch" or "caught") of the
* current catch. */
- BasicBlock* catch; /* Current enclosing catch */
+ BasicBlock* block; /* Current enclosing catch */
int catchDepth; /* Nesting depth of the current catch */
catchState = bbPtr->catchState;
- catch = bbPtr->enclosingCatch;
+ block = bbPtr->enclosingCatch;
catchDepth = bbPtr->catchDepth;
while (catchDepth > 0) {
--catchDepth;
- if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) {
- catches[catchDepth] = catch;
+ if (catches[catchDepth] != block && catchState < BBCS_CAUGHT) {
+ catches[catchDepth] = block;
}
- catchState = catch->catchState;
- catch = catch->enclosingCatch;
+ catchState = block->catchState;
+ block = block->enclosingCatch;
}
}
@@ -4096,7 +4105,7 @@ StackFreshCatches(
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
ExceptionRange* range; /* Exception range for a specific catch */
- BasicBlock* catch; /* Catch block being examined */
+ BasicBlock* block; /* Catch block being examined */
BasicBlock* errorExit; /* Error exit from the catch block */
Tcl_HashEntry* entryPtr;
@@ -4113,7 +4122,7 @@ StackFreshCatches(
* Create an exception range for a block that needs one.
*/
- catch = catches[catchDepth];
+ block = catches[catchDepth];
catchIndices[catchDepth] =
TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
@@ -4123,13 +4132,13 @@ StackFreshCatches(
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(catch->jumpTarget));
+ TclGetString(block->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
}
- errorExit = Tcl_GetHashValue(entryPtr);
+ errorExit = (BasicBlock*)Tcl_GetHashValue(entryPtr);
range->catchOffset = errorExit->startOffset;
}
}
@@ -4260,12 +4269,12 @@ AddBasicBlockRangeToErrorInfo(
Tcl_Obj* lineNo; /* Line number in the source */
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
- lineNo = Tcl_NewIntObj(bbPtr->startLine);
+ lineNo = Tcl_NewWideIntObj(bbPtr->startLine);
Tcl_IncrRefCount(lineNo);
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,11 +4311,9 @@ AddBasicBlockRangeToErrorInfo(
static void
DupAssembleCodeInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj *))
{
- (void)srcPtr;
- (void)copyPtr;
return;
}
@@ -4332,13 +4339,12 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
- objPtr->typePtr = NULL;
+ ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
/*
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index 14804e4..c432e4f 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -118,7 +118,7 @@ Tcl_AsyncCreate(
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- asyncPtr = ckalloc(sizeof(AsyncHandler));
+ asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fe64f18..6c14f45 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -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
@@ -66,12 +106,23 @@ typedef struct {
char *result; /* The script cancellation result or NULL for
* a default result. */
int length; /* Length of the above error message. */
- ClientData clientData; /* Ignored */
+ ClientData 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,6 +145,7 @@ 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);
@@ -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);
+#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;
@@ -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,6 +303,7 @@ 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},
@@ -228,7 +315,9 @@ static const CmdInfo builtInCmds[] = {
{"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},
@@ -286,9 +375,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 +383,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 +453,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 +558,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,6 +595,13 @@ TclFinalizeEvaluation(void)
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_DeleteHashTable(&commandTypeTable);
+ commandTypeInit = 0;
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
}
/*
@@ -472,7 +645,7 @@ Tcl_CreateInterp(void)
char mathFuncName[32];
CallFrame *framePtr;
- TclInitSubsystems();
+ Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -480,7 +653,6 @@ Tcl_CreateInterp(void)
*/
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
- /*NOTREACHED*/
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
@@ -491,9 +663,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)) {
- /*NOTREACHED*/
+ if ((offsetof(Tcl_StatBuf,st_atime) != 32)
+ || (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
@@ -504,19 +675,37 @@ Tcl_CreateInterp(void)
Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
cancelTableInitialized = 1;
}
+
Tcl_MutexUnlock(&cancelLock);
}
+ if (commandTypeInit == 0) {
+ TclRegisterCommandTypeName(TclObjInterpProc, "proc");
+ TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
+ TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclSlaveObjCmd, "slave");
+ 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
* object type table and other object management code.
*/
- iPtr = ckalloc(sizeof(Interp));
+ iPtr = (Interp *)ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
+#ifdef TCL_NO_DEPRECATED
+ iPtr->result = &tclEmptyString;
+#else
iPtr->result = iPtr->resultSpace;
+#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
iPtr->objResultPtr = Tcl_NewObj();
@@ -540,10 +729,10 @@ Tcl_CreateInterp(void)
*/
iPtr->cmdFramePtr = NULL;
- iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable));
- iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable));
- iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable));
- iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
+ iPtr->linePBodyPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
+ iPtr->lineBCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
+ iPtr->lineLAPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
+ iPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
@@ -576,23 +765,26 @@ 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;
/* 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;
@@ -607,7 +799,9 @@ Tcl_CreateInterp(void)
iPtr->emptyObjPtr = Tcl_NewObj();
/* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
+#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
+#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
@@ -641,7 +835,7 @@ Tcl_CreateInterp(void)
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
- framePtr = ckalloc(sizeof(CallFrame));
+ framePtr = (CallFrame *)ckalloc(sizeof(CallFrame));
(void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
framePtr->objc = 0;
@@ -671,7 +865,7 @@ Tcl_CreateInterp(void)
iPtr->asyncCancelMsg = Tcl_NewObj();
- cancelInfo = ckalloc(sizeof(CancelInfo));
+ cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo));
cancelInfo->interp = interp;
iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
@@ -740,8 +934,8 @@ Tcl_CreateInterp(void)
* cache was already initialised by the call to alloc the interp struct.
*/
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
- iPtr->allocCache = TclpGetAllocCache();
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
+ iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
#endif
@@ -770,7 +964,7 @@ Tcl_CreateInterp(void)
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
- cmdPtr = ckalloc(sizeof(Command));
+ cmdPtr = (Command *)ckalloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = iPtr->globalNsPtr;
cmdPtr->refCount = 1;
@@ -810,6 +1004,7 @@ Tcl_CreateInterp(void)
TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
+ TclInitProcessCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -850,14 +1045,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) {
@@ -887,7 +1078,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);
}
@@ -903,7 +1094,7 @@ Tcl_CreateInterp(void)
#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
- TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData));
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)ckalloc(sizeof(TclOpCmdClientData));
occdPtr->op = opcmdInfoPtr->name;
occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
@@ -949,24 +1140,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
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
@@ -985,11 +1178,11 @@ Tcl_CreateInterp(void)
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
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)));
}
/*
@@ -999,6 +1192,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,12 +1207,77 @@ static void
DeleteOpCmdClientData(
ClientData clientData)
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
ckfree(occdPtr);
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * 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,
+ (void *) implementationProc, &isNew);
+ Tcl_SetHashValue(hPtr, (void *) nameStr);
+ } else {
+ hPtr = Tcl_FindHashEntry(&commandTypeTable,
+ (void *) 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 --
@@ -1036,7 +1297,8 @@ int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
- register const CmdInfo *cmdInfoPtr;
+ const CmdInfo *cmdInfoPtr;
+ const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1046,12 +1308,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(
+ ClientData 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 --
@@ -1082,17 +1415,17 @@ Tcl_CallWhenDeleted(
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
- Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
+ (int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
- AssocData *dPtr = ckalloc(sizeof(AssocData));
+ AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == NULL) {
- iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
+ iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
@@ -1139,7 +1472,7 @@ Tcl_DontCallWhenDeleted(
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
- dPtr = Tcl_GetHashValue(hPtr);
+ dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
@@ -1181,14 +1514,14 @@ Tcl_SetAssocData(
int isNew;
if (iPtr->assocData == NULL) {
- iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
+ iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
if (isNew == 0) {
- dPtr = Tcl_GetHashValue(hPtr);
+ dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
} else {
- dPtr = ckalloc(sizeof(AssocData));
+ dPtr = (AssocData *)ckalloc(sizeof(AssocData));
}
dPtr->proc = proc;
dPtr->clientData = clientData;
@@ -1229,7 +1562,7 @@ Tcl_DeleteAssocData(
if (hPtr == NULL) {
return;
}
- dPtr = Tcl_GetHashValue(hPtr);
+ dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
@@ -1274,7 +1607,7 @@ Tcl_GetAssocData(
if (hPtr == NULL) {
return NULL;
}
- dPtr = Tcl_GetHashValue(hPtr);
+ dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if (procPtr != NULL) {
*procPtr = dPtr->proc;
}
@@ -1425,7 +1758,7 @@ DeleteInterpProc(
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
- CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr);
+ CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
if (cancelInfo != NULL) {
if (cancelInfo->result != NULL) {
@@ -1483,7 +1816,7 @@ DeleteInterpProc(
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr));
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
@@ -1502,7 +1835,7 @@ DeleteInterpProc(
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
- dPtr = Tcl_GetHashValue(hPtr);
+ dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
@@ -1531,8 +1864,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);
@@ -1554,10 +1889,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);
@@ -1595,7 +1932,7 @@ DeleteInterpProc(
for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
- CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
+ CmdFrame *cfPtr = (CmdFrame *)Tcl_GetHashValue(hPtr);
Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
procPtr->iPtr = NULL;
@@ -1619,7 +1956,7 @@ DeleteInterpProc(
for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
- ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr);
+ ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
@@ -1655,7 +1992,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
- ckfree((char *) iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -1783,7 +2120,7 @@ Tcl_HideCommand(
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
- hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable));
+ hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
@@ -1923,7 +2260,7 @@ Tcl_ExposeCommand(
hiddenCmdToken, NULL);
return TCL_ERROR;
}
- cmdPtr = Tcl_GetHashValue(hPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Check that we have a true global namespace command (enforced by
@@ -2119,7 +2456,7 @@ Tcl_CreateCommand(
* An existing command conflicts. Try to delete it...
*/
- cmdPtr = Tcl_GetHashValue(hPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Be careful to preserve any existing import links so we can restore
@@ -2174,7 +2511,7 @@ Tcl_CreateCommand(
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
- cmdPtr = ckalloc(sizeof(Command));
+ cmdPtr = (Command *)ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
@@ -2201,7 +2538,7 @@ Tcl_CreateCommand(
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
- dataPtr = refCmdPtr->objClientData;
+ dataPtr = (ImportedCmdData *)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
@@ -2296,30 +2633,33 @@ Tcl_CreateObjCommand(
}
Tcl_Command
-TclCreateObjCommandInNs (
+TclCreateObjCommandInNs(
Tcl_Interp *interp,
- const char *cmdName, /* Name of command, without any namespace components */
- Tcl_Namespace *namespace, /* The namespace to create the command in */
+ const char *cmdName, /* Name of command, without any namespace
+ * components. */
+ 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
* function. */
- Tcl_CmdDeleteProc *deleteProc
+ Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
-) {
+{
int deleted = 0, isNew = 0;
Command *cmdPtr;
ImportRef *oldRefPtr = NULL;
ImportedCmdData *dataPtr;
Tcl_HashEntry *hPtr;
- Namespace *nsPtr = (Namespace *) namespace;
+ Namespace *nsPtr = (Namespace *) namesp;
+
/*
- * If the command name we seek to create already exists, we need to
- * delete that first. That can be tricky in the presence of traces.
- * Loop until we no longer find an existing command in the way, or
- * until we've deleted one command and that didn't finish the job.
+ * If the command name we seek to create already exists, we need to delete
+ * that first. That can be tricky in the presence of traces. Loop until we
+ * no longer find an existing command in the way, or until we've deleted
+ * one command and that didn't finish the job.
*/
+
while (1) {
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
@@ -2335,7 +2675,7 @@ TclCreateObjCommandInNs (
* An existing command conflicts. Try to delete it...
*/
- cmdPtr = Tcl_GetHashValue(hPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* [***] This is wrong. See Tcl Bug a16752c252.
@@ -2374,7 +2714,7 @@ TclCreateObjCommandInNs (
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
nsPtr = (Namespace *) TclEnsureNamespace(interp,
- (Tcl_Namespace *)cmdPtr->nsPtr);
+ (Tcl_Namespace *) cmdPtr->nsPtr);
TclNsDecrRefCount(cmdPtr->nsPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
@@ -2386,9 +2726,9 @@ TclCreateObjCommandInNs (
}
if (!isNew) {
/*
- * If the deletion callback recreated the command, just throw away
- * the new command (if we try to delete it again, we could get
- * stuck in an infinite loop).
+ * If the deletion callback recreated the command, just throw away the
+ * new command (if we try to delete it again, we could get stuck in an
+ * infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
@@ -2416,7 +2756,7 @@ TclCreateObjCommandInNs (
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
- cmdPtr = ckalloc(sizeof(Command));
+ cmdPtr = (Command *)ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
@@ -2443,7 +2783,8 @@ TclCreateObjCommandInNs (
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
- dataPtr = refCmdPtr->objClientData;
+
+ dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
@@ -2485,16 +2826,16 @@ int
TclInvokeStringCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
- register int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Command *cmdPtr = clientData;
+ Command *cmdPtr = (Command *)clientData;
int i, result;
- const char **argv =
- TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
+ const char **argv = (const char **)
+ 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;
@@ -2520,7 +2861,7 @@ TclInvokeStringCommand(
* in the Command structure.
*
* Results:
- * A standard Tcl string result value.
+ * A standard Tcl result value.
*
* Side effects:
* Besides those side effects of the called Tcl_ObjCmdProc,
@@ -2534,13 +2875,13 @@ TclInvokeObjectCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
- register const char **argv) /* Argument strings. */
+ const char **argv) /* Argument strings. */
{
- Command *cmdPtr = clientData;
+ Command *cmdPtr = ( Command *) clientData;
Tcl_Obj *objPtr;
int i, length, result;
- Tcl_Obj **objv =
- TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *)));
+ Tcl_Obj **objv = (Tcl_Obj **)
+ TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *)));
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
@@ -2748,7 +3089,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);
@@ -2974,7 +3315,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. */
@@ -2991,7 +3332,7 @@ Tcl_GetCommandName(
return "";
}
- return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+ return (const char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}
/*
@@ -3025,7 +3366,7 @@ Tcl_GetCommandFullName(
{
Interp *iPtr = (Interp *) interp;
- register Command *cmdPtr = (Command *) command;
+ Command *cmdPtr = (Command *) command;
char *name;
/*
@@ -3041,7 +3382,7 @@ Tcl_GetCommandFullName(
}
}
if (cmdPtr->hPtr != NULL) {
- name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+ name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
Tcl_AppendToObj(objPtr, name, -1);
}
}
@@ -3115,13 +3456,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
@@ -3143,6 +3477,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;
}
@@ -3248,6 +3590,13 @@ Tcl_DeleteCommandFromToken(
if (cmdPtr->hPtr != NULL) {
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++;
}
/*
@@ -3301,7 +3650,7 @@ CallCommandTraces(
* trigger, either TCL_TRACE_DELETE or
* TCL_TRACE_RENAME. */
{
- register CommandTrace *tracePtr;
+ CommandTrace *tracePtr;
ActiveCommandTrace active;
char *result;
Tcl_Obj *oldNamePtr = NULL;
@@ -3414,10 +3763,10 @@ CallCommandTraces(
static int
CancelEvalProc(
ClientData clientData, /* Interp to cancel the script in progress. */
- Tcl_Interp *interp, /* Ignored */
+ TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
- CancelInfo *cancelInfo = clientData;
+ CancelInfo *cancelInfo = (CancelInfo *)clientData;
Interp *iPtr;
if (cancelInfo != NULL) {
@@ -3491,11 +3840,10 @@ CancelEvalProc(
void
TclCleanupCommand(
- register Command *cmdPtr) /* Points to the Command structure to
+ Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
- cmdPtr->refCount--;
- if (cmdPtr->refCount <= 0) {
+ if (cmdPtr->refCount-- <= 1) {
ckfree(cmdPtr);
}
}
@@ -3522,6 +3870,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3537,11 +3886,11 @@ Tcl_CreateMathFunc(
* function. */
{
Tcl_DString bigName;
- OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData));
+ OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData));
data->proc = proc;
data->numArgs = numArgs;
- data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType));
+ data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
data->clientData = clientData;
@@ -3572,14 +3921,14 @@ Tcl_CreateMathFunc(
static int
OldMathFuncProc(
- ClientData clientData, /* Ponter to OldMathFuncData describing the
+ ClientData clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
Tcl_Obj *valuePtr;
- OldMathFuncData *dataPtr = clientData;
+ OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
Tcl_Value funcResult, *args;
int result;
int j, k;
@@ -3598,15 +3947,20 @@ OldMathFuncProc(
* Convert arguments from Tcl_Obj's to Tcl_Value's.
*/
- args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
+ args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
for (j = 1, k = 0; j < objc; ++j, ++k) {
/* TODO: Convert to TclGetNumberFromObj? */
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_ObjIntRep *irPtr
+ = TclFetchIntRep(valuePtr, &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ result = TCL_OK;
+ }
}
#endif
if (result != TCL_OK) {
@@ -3617,7 +3971,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;
}
@@ -3685,7 +4039,7 @@ 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);
} else {
@@ -3716,7 +4070,7 @@ static void
OldMathFuncDeleteProc(
ClientData clientData)
{
- OldMathFuncData *dataPtr = clientData;
+ OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
ckfree(dataPtr->argTypes);
ckfree(dataPtr);
@@ -3789,7 +4143,7 @@ Tcl_GetMathFuncInfo(
*/
if (cmdPtr->objProc == &OldMathFuncProc) {
- OldMathFuncData *dataPtr = cmdPtr->clientData;
+ OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData;
*procPtr = dataPtr->proc;
*numArgsPtr = dataPtr->numArgs;
@@ -3853,6 +4207,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -3876,7 +4231,7 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
/*
* Reset both the interpreter's string and object results and clear out
@@ -3948,7 +4303,7 @@ TclResetCancellation(
Tcl_Interp *interp,
int force)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (iPtr == NULL) {
return TCL_ERROR;
@@ -3990,7 +4345,7 @@ Tcl_Canceled(
Tcl_Interp *interp,
int flags)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
/*
* Has the current script in progress for this interpreter been canceled
@@ -4037,7 +4392,7 @@ Tcl_Canceled(
*/
if (iPtr->asyncCancelMsg != NULL) {
- message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
@@ -4125,7 +4480,7 @@ Tcl_CancelEval(
goto done;
}
- cancelInfo = Tcl_GetHashValue(hPtr);
+ cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
/*
* Populate information needed by the interpreter thread to fulfill the
@@ -4136,9 +4491,9 @@ Tcl_CancelEval(
*/
if (resultObjPtr != NULL) {
- result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
- cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length);
- memcpy(cancelInfo->result, result, (size_t) 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. */
} else {
cancelInfo->result = NULL;
@@ -4255,12 +4610,12 @@ static int
EvalObjvCore(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
- Command *cmdPtr = NULL, *preCmdPtr = data[0];
+ Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
int objc = PTR2INT(data[2]);
- Tcl_Obj **objv = data[3];
+ Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
Namespace *lookupNsPtr = NULL;
int enterTracesDone = 0;
@@ -4415,12 +4770,12 @@ static int
Dispatch(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
- Tcl_ObjCmdProc *objProc = data[0];
+ Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
ClientData clientData = data[1];
int objc = PTR2INT(data[2]);
- Tcl_Obj **objv = data[3];
+ Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
#ifdef USE_DTRACE
@@ -4464,7 +4819,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
@@ -4476,9 +4833,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.
@@ -4601,7 +4960,7 @@ TEOV_RestoreVarFrame(
Tcl_Interp *interp,
int result)
{
- ((Interp *) interp)->varFramePtr = data[0];
+ ((Interp *) interp)->varFramePtr = (CallFrame *)data[0];
return result;
}
@@ -4645,9 +5004,9 @@ TEOV_Error(
const char *cmdString;
int cmdLen;
int objc = PTR2INT(data[0]);
- Tcl_Obj **objv = data[1];
+ Tcl_Obj **objv = (Tcl_Obj **)data[1];
- if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){
+ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
/*
* If there was an error, a command string will be needed for the
* error log: get it out of the itemPtr. The details depend on the
@@ -4655,7 +5014,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);
}
@@ -4707,7 +5066,7 @@ TEOV_NotFound(
Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
- newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc);
+ newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
/*
* Copy command prefix from unknown handler and add on the real command's
@@ -4719,7 +5078,7 @@ TEOV_NotFound(
newObjv[i] = handlerObjv[i];
Tcl_IncrRefCount(newObjv[i]);
}
- memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc);
+ memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * objc);
/*
* Look up and invoke the handler (by recursive call to this function). If
@@ -4768,8 +5127,8 @@ TEOV_NotFoundCallback(
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
- Tcl_Obj **objv = data[1];
- Namespace *savedNsPtr = data[2];
+ Tcl_Obj **objv = (Tcl_Obj **)data[1];
+ Namespace *savedNsPtr = (Namespace *)data[2];
int i;
@@ -4799,9 +5158,9 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int length, traceCode = TCL_OK;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
@@ -4849,14 +5208,14 @@ TEOV_RunLeaveTraces(
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
- Tcl_Obj *commandPtr = data[1];
- Command *cmdPtr = data[2];
- Tcl_Obj **objv = data[3];
+ Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
+ Command *cmdPtr = (Command *)data[2];
+ Tcl_Obj **objv = (Tcl_Obj **)data[3];
int length;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){
+ if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
@@ -4942,6 +5301,7 @@ Tcl_EvalTokensStandard(
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -4989,6 +5349,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5072,12 +5433,12 @@ TclEvalEx(
* state has been allocated while evaluating
* the script, so that it can be freed
* properly if an error occurs. */
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
- CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
- Tcl_Obj **stackObjArray =
+ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
+ CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
+ Tcl_Obj **stackObjArray = (Tcl_Obj **)
TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
- int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int));
- int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int));
+ int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
+ int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
/* TIP #280 Structures for tracking of command
* locations. */
int *clNext = NULL; /* Pointer for the tracking of invisible
@@ -5213,9 +5574,9 @@ TclEvalEx(
*/
if (numWords > minObjs) {
- expand = ckalloc(numWords * sizeof(int));
- objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *));
- lineSpace = ckalloc(numWords * sizeof(int));
+ expand = (int *)ckalloc(numWords * sizeof(int));
+ objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *));
+ lineSpace = (int *)ckalloc(numWords * sizeof(int));
}
expandRequested = 0;
objv = objvSpace;
@@ -5301,8 +5662,8 @@ TclEvalEx(
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
- ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
- lines = lineSpace = ckalloc(objectsNeeded * sizeof(int));
+ (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
+ lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
@@ -5505,7 +5866,7 @@ TclAdvanceLines(
const char *start,
const char *end)
{
- register const char *p;
+ const char *p;
for (p = start; p < end; p++) {
if (*p == '\n') {
@@ -5600,7 +5961,7 @@ TclArgumentEnter(
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
- int new, i;
+ int isNew, i;
Tcl_HashEntry *hPtr;
CFWord *cfwPtr;
@@ -5616,14 +5977,14 @@ TclArgumentEnter(
if (cfPtr->line[i] < 0) {
continue;
}
- hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new);
- if (new) {
+ hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);
+ if (isNew) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
- cfwPtr = ckalloc(sizeof(CFWord));
+ cfwPtr = (CFWord *)ckalloc(sizeof(CFWord));
cfwPtr->framePtr = cfPtr;
cfwPtr->word = i;
cfwPtr->refCount = 1;
@@ -5634,7 +5995,7 @@ TclArgumentEnter(
* relevant. Just remember the reference to prevent early removal.
*/
- cfwPtr = Tcl_GetHashValue(hPtr);
+ cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
cfwPtr->refCount++;
}
}
@@ -5677,10 +6038,9 @@ TclArgumentRelease(
if (!hPtr) {
continue;
}
- cfwPtr = Tcl_GetHashValue(hPtr);
+ cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
- cfwPtr->refCount--;
- if (cfwPtr->refCount > 0) {
+ if (cfwPtr->refCount-- > 1) {
continue;
}
@@ -5730,7 +6090,7 @@ TclArgumentBCEnter(
if (!hePtr) {
return;
}
- eclPtr = Tcl_GetHashValue(hePtr);
+ eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
ePtr = &eclPtr->loc[cmd];
/*
@@ -5763,10 +6123,10 @@ TclArgumentBCEnter(
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
- int isnew;
+ int isNew;
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
- objv[word], &isnew);
- CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC));
+ objv[word], &isNew);
+ CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->obj = objv[word];
@@ -5775,7 +6135,7 @@ TclArgumentBCEnter(
cfwPtr->nextPtr = lastPtr;
lastPtr = cfwPtr;
- if (isnew) {
+ if (isNew) {
/*
* The word is not on the stack yet, remember the current
* location and initialize references.
@@ -5790,7 +6150,7 @@ TclArgumentBCEnter(
* information in the new structure.
*/
- cfwPtr->prevPtr = Tcl_GetHashValue(hPtr);
+ cfwPtr->prevPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, cfwPtr);
@@ -5832,7 +6192,7 @@ TclArgumentBCRelease(
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
- CFWordBC *xPtr = Tcl_GetHashValue(hPtr);
+ CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
Tcl_Panic("TclArgumentBC Enter/Release Mismatch");
@@ -5887,7 +6247,7 @@ TclArgumentGet(
* up by the caller. It knows better than us.
*/
- if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
+ if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) {
return;
}
@@ -5898,7 +6258,7 @@ TclArgumentGet(
hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
- CFWord *cfwPtr = Tcl_GetHashValue(hPtr);
+ CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
*wordPtr = cfwPtr->word;
*cfPtrPtr = cfwPtr->framePtr;
@@ -5912,7 +6272,7 @@ TclArgumentGet(
hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
if (hPtr) {
- CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr);
+ CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
framePtr = cfwPtr->framePtr;
framePtr->data.tebc.pc = (char *) (((ByteCode *)
@@ -5945,6 +6305,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
@@ -5997,6 +6358,7 @@ Tcl_GlobalEvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6030,7 +6392,7 @@ int
Tcl_EvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
- register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
@@ -6043,7 +6405,7 @@ int
TclEvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
- register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
@@ -6062,7 +6424,7 @@ int
TclNREvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
- register Tcl_Obj *objPtr, /* Pointer to object containing commands to
+ Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
@@ -6126,7 +6488,7 @@ TclNREvalObjEx(
* should be pushed, as needed by alias and ensemble redirections.
*/
- eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ eoFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
eoFramePtr->nline = 0;
eoFramePtr->line = NULL;
@@ -6150,7 +6512,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- ListObjGetElements(listPtr, objc, objv);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
@@ -6218,7 +6580,7 @@ TclNREvalObjEx(
Tcl_IncrRefCount(objPtr);
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
@@ -6235,8 +6597,8 @@ TEOEx_ByteCodeCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- CallFrame *savedVarFramePtr = data[0];
- Tcl_Obj *objPtr = data[1];
+ CallFrame *savedVarFramePtr = (CallFrame *)data[0];
+ Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
int allowExceptions = PTR2INT(data[2]);
if (iPtr->numLevels == 0) {
@@ -6249,7 +6611,7 @@ TEOEx_ByteCodeCallback(
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
@@ -6281,9 +6643,9 @@ TEOEx_ListCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr = data[0];
- CmdFrame *eoFramePtr = data[1];
- Tcl_Obj *objPtr = data[2];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
+ CmdFrame *eoFramePtr = (CmdFrame *)data[1];
+ Tcl_Obj *objPtr = (Tcl_Obj *)data[2];
/*
* Remove the cmdFrame
@@ -6370,7 +6732,7 @@ Tcl_ExprLong(
const char *exprstring, /* Expression to evaluate. */
long *ptr) /* Where to store result. */
{
- register Tcl_Obj *exprPtr;
+ Tcl_Obj *exprPtr;
int result = TCL_OK;
if (*exprstring == '\0') {
/*
@@ -6397,7 +6759,7 @@ Tcl_ExprDouble(
const char *exprstring, /* Expression to evaluate. */
double *ptr) /* Where to store result. */
{
- register Tcl_Obj *exprPtr;
+ Tcl_Obj *exprPtr;
int result = TCL_OK;
if (*exprstring == '\0') {
@@ -6477,7 +6839,7 @@ int
Tcl_ExprLongObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register Tcl_Obj *objPtr, /* Expression to evaluate. */
+ Tcl_Obj *objPtr, /* Expression to evaluate. */
long *ptr) /* Where to store long result. */
{
Tcl_Obj *resultPtr;
@@ -6506,8 +6868,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;
@@ -6525,7 +6886,7 @@ int
Tcl_ExprDoubleObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register Tcl_Obj *objPtr, /* Expression to evaluate. */
+ Tcl_Obj *objPtr, /* Expression to evaluate. */
double *ptr) /* Where to store double result. */
{
Tcl_Obj *resultPtr;
@@ -6561,7 +6922,7 @@ int
Tcl_ExprBooleanObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register Tcl_Obj *objPtr, /* Expression to evaluate. */
+ Tcl_Obj *objPtr, /* Expression to evaluate. */
int *ptr) /* Where to store 0/1 result. */
{
Tcl_Obj *resultPtr;
@@ -6668,12 +7029,12 @@ TclObjInvoke(
int
TclNRInvoke(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
const char *cmdName; /* Name of the command from objv[0]. */
Tcl_HashEntry *hPtr = NULL;
@@ -6691,7 +7052,7 @@ TclNRInvoke(
NULL);
return TCL_ERROR;
}
- cmdPtr = Tcl_GetHashValue(hPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Avoid the exception-handling brain damage when numLevels == 0
@@ -6711,11 +7072,12 @@ TclNRInvoke(
static int
NRPostInvoke(
- ClientData clientData[],
+ TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *)interp;
+
iPtr->numLevels--;
return result;
}
@@ -6753,7 +7115,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);
@@ -6800,11 +7162,10 @@ Tcl_AppendObjToErrorInfo(
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
- int length;
- const char *message = TclGetStringFromObj(objPtr, &length);
+ const char *message = TclGetString(objPtr);
Tcl_IncrRefCount(objPtr);
- Tcl_AddObjErrorInfo(interp, message, length);
+ Tcl_AddObjErrorInfo(interp, message, objPtr->length);
Tcl_DecrRefCount(objPtr);
}
@@ -6827,6 +7188,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
@@ -6836,6 +7198,7 @@ Tcl_AddErrorInfo(
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6867,7 +7230,7 @@ Tcl_AddObjErrorInfo(
int length) /* The number of bytes in the message. If < 0,
* then append all bytes up to a NULL byte. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
/*
* If we are just starting to log an error, errorInfo is initialized from
@@ -6876,7 +7239,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
@@ -6886,9 +7250,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);
@@ -6951,7 +7315,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;
}
@@ -6973,7 +7337,6 @@ Tcl_VarEvalVA(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_VarEval(
Tcl_Interp *interp,
@@ -7008,6 +7371,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
@@ -7015,16 +7379,17 @@ Tcl_GlobalEval(
* command. */
const char *command) /* Command to evaluate. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
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 */
/*
*----------------------------------------------------------------------
@@ -7146,7 +7511,7 @@ Tcl_GetVersion(
static int
ExprCeilFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7162,9 +7527,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_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7182,7 +7551,7 @@ ExprCeilFunc(
static int
ExprFloorFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7198,9 +7567,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_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7218,7 +7591,7 @@ ExprFloorFunc(
static int
ExprIsqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
@@ -7272,7 +7645,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;
}
@@ -7300,10 +7673,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;
@@ -7318,7 +7697,7 @@ ExprIsqrtFunc(
static int
ExprSqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7334,9 +7713,13 @@ 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_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7345,10 +7728,17 @@ ExprSqrtFunc(
if ((d >= 0.0) && TclIsInfinite(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 {
@@ -7377,10 +7767,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_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7437,10 +7831,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_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d1 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7448,10 +7846,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_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d2 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7463,7 +7865,7 @@ ExprBinaryFunc(
static int
ExprAbsFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7482,28 +7884,32 @@ ExprAbsFunc(
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 (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;
}
@@ -7527,27 +7933,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:
@@ -7572,7 +7964,7 @@ ExprAbsFunc(
static int
ExprBoolFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7593,7 +7985,7 @@ ExprBoolFunc(
static int
ExprDoubleFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7607,7 +7999,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objv[1]->typePtr == &tclDoubleType) {
+ if (TclHasIntRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7619,8 +8011,8 @@ ExprDoubleFunc(
}
static int
-ExprEntierFunc(
- ClientData clientData, /* Ignored. */
+ExprIntFunc(
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7640,19 +8032,7 @@ ExprEntierFunc(
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) {
@@ -7661,6 +8041,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;
}
}
@@ -7682,73 +8067,91 @@ ExprEntierFunc(
}
static int
-ExprIntFunc(
- ClientData clientData, /* Ignored. */
+ExprWideFunc(
+ TCL_UNUSED(ClientData),
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(ClientData),
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;
+ ClientData 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 (TclGetNumberFromObj(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(ClientData),
+ 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(ClientData),
+ 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(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7779,7 +8182,7 @@ ExprRandFunc(
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
- iPtr->randSeed &= (unsigned long) 0x7FFFFFFF;
+ iPtr->randSeed &= 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
@@ -7841,7 +8244,7 @@ ExprRandFunc(
static int
ExprRoundFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7862,7 +8265,7 @@ ExprRoundFunc(
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) {
@@ -7872,27 +8275,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;
}
}
@@ -7916,14 +8323,14 @@ ExprRoundFunc(
static int
ExprSrandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
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.
@@ -7934,20 +8341,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;
}
/*
@@ -7956,8 +8351,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;
}
@@ -7968,7 +8362,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(ClientData),
+ 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;
+ ClientData ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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(ClientData),
+ 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;
+ ClientData ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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(ClientData),
+ 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;
+ ClientData ptr;
+ int type, result = 1;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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(ClientData),
+ 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;
+ ClientData ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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(ClientData),
+ 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;
+ ClientData ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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(ClientData),
+ 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;
+ ClientData ptr;
+ int type, result = 0;
+
+ if (objc != 3) {
+ MathFuncWrongNumArgs(interp, 3, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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 (TclGetNumberFromObj(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(ClientData),
+ 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;
+ ClientData ptr;
+ int type;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "floatValue");
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(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;
}
/*
@@ -7995,7 +8778,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) {
@@ -8030,8 +8813,8 @@ MathFuncWrongNumArgs(
static int
DTraceObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(ClientData),
+ TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
@@ -8237,23 +9020,26 @@ Tcl_NRCreateCommand(
* 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;
}
Tcl_Command
-TclNRCreateCommandInNs (
+TclNRCreateCommandInNs(
Tcl_Interp *interp,
const char *cmdName,
Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc,
ClientData clientData,
- Tcl_CmdDeleteProc *deleteProc) {
+ 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;
@@ -8357,7 +9143,6 @@ TclPushTailcallPoint(
TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
((Interp *) interp)->numLevels++;
}
-
/*
*----------------------------------------------------------------------
@@ -8393,7 +9178,6 @@ TclSetTailcall(
}
runPtr->data[1] = listPtr;
}
-
/*
*----------------------------------------------------------------------
@@ -8413,7 +9197,7 @@ TclSetTailcall(
int
TclNRTailcallObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8465,7 +9249,6 @@ TclNRTailcallObjCmd(
}
return TCL_RETURN;
}
-
/*
*----------------------------------------------------------------------
@@ -8484,7 +9267,7 @@ TclNRTailcallEval(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr = data[0], *nsObjPtr;
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
@@ -8519,10 +9302,11 @@ TclNRTailcallEval(
int
TclNRReleaseValues(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
+
while (i < 4) {
if (data[i]) {
Tcl_DecrRefCount((Tcl_Obj *) data[i]);
@@ -8533,7 +9317,6 @@ TclNRReleaseValues(
}
return result;
}
-
void
Tcl_NRAddCallback(
@@ -8607,7 +9390,7 @@ TclNRYieldObjCmd(
int
TclNRYieldToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8661,9 +9444,9 @@ static int
RewindCoroutineCallback(
ClientData 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
@@ -8688,7 +9471,7 @@ static void
DeleteCoroutine(
ClientData clientData)
{
- CoroutineData *corPtr = clientData;
+ CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
NRE_callback *rootPtr = TOP_CB(interp);
@@ -8703,7 +9486,7 @@ NRCoroutineCallerCallback(
Tcl_Interp *interp,
int result)
{
- CoroutineData *corPtr = data[0];
+ CoroutineData *corPtr = (CoroutineData *)data[0];
Command *cmdPtr = corPtr->cmdPtr;
/*
@@ -8749,7 +9532,7 @@ NRCoroutineExitCallback(
Tcl_Interp *interp,
int result)
{
- CoroutineData *corPtr = data[0];
+ CoroutineData *corPtr = (CoroutineData *)data[0];
Command *cmdPtr = corPtr->cmdPtr;
/*
@@ -8812,9 +9595,9 @@ int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
- CoroutineData *corPtr = data[0];
+ CoroutineData *corPtr = (CoroutineData *)data[0];
int type = PTR2INT(data[1]);
int numLevels, unused;
int *stackLevel = &unused;
@@ -8891,11 +9674,11 @@ static int
TclNREvalList(
ClientData data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
int objc;
Tcl_Obj **objv;
- Tcl_Obj *listPtr = data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
Tcl_IncrRefCount(listPtr);
@@ -8917,7 +9700,7 @@ TclNREvalList(
static int
CoroTypeObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8948,7 +9731,7 @@ CoroTypeObjCmd(
* future.
*/
- corPtr = cmdPtr->objClientData;
+ corPtr = (CoroutineData *)cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
return TCL_OK;
@@ -8977,27 +9760,47 @@ 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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Command *cmdPtr;
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
/*
* Usage more or less like tailcall:
- * inject coroName cmd ?arg1 arg2 ...?
+ * coroinject coroName cmd ?arg1 arg2 ...?
*/
if (objc < 3) {
@@ -9005,16 +9808,249 @@ 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 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 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.
+ */
+
+ 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(ClientData),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr;
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+ int numLevels, unused;
+ int *stackLevel = &unused;
+
+ /*
+ * Usage more or less like tailcall:
+ * coroprobe 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 probe command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a probe 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.
+ */
+
+ 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 = stackLevel;
+ 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(
+ ClientData 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]);
+ ClientData 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_NewIntObj(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);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ return TclNREvalObjv(interp, objc, objv, 0, NULL);
+}
+
+static int
+InjectHandlerPostCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CoroutineData *corPtr = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
+ int nargs = PTR2INT(data[2]);
+ ClientData isProbe = data[3];
+ int numLevels;
+
+ /*
+ * 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;
+ 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(ClientData),
+ 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));
@@ -9042,12 +10078,12 @@ TclNRInterpCoroutine(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- CoroutineData *corPtr = clientData;
+ CoroutineData *corPtr = (CoroutineData *)clientData;
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;
}
@@ -9101,7 +10137,7 @@ TclNRInterpCoroutine(
int
TclNRCoroutineObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9142,7 +10178,7 @@ TclNRCoroutineObjCmd(
* struct and create the corresponding command.
*/
- corPtr = ckalloc(sizeof(CoroutineData));
+ corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData));
cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
(Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
@@ -9164,7 +10200,7 @@ TclNRCoroutineObjCmd(
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
- corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
+ corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
@@ -9234,7 +10270,7 @@ TclNRCoroutineObjCmd(
int
TclInfoCoroutineCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 8f4f6ab..bb82fe7 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -12,9 +12,10 @@
*/
#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,9 +57,12 @@
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);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
@@ -155,35 +159,103 @@ 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 object types represent 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 how we got to this point and where we
+ * might go from here.
+ *
+ * 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. The simplest 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. Full Stop. The setFromAnyProc
+ * signature has a completion code return value for just this reason, to
+ * reject invalid inputs.
+ *
+ * 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. When a Tcl value has a
+ * string representation, we are required to accept that as the true value.
+ * Bytearray values that possess a string representation cannot be processed
+ * as bytearrays because we cannot know which true value that bytearray
+ * represents. The consequence is that we drag around an internal rep that we
+ * cannot make any use of. This painful price is extracted at any point after
+ * a string rep happens to be generated for the value. This happens even when
+ * the troublesome codepoints outside the byte range never show up. This
+ * happens rather routinely in normal Tcl operations unless we burden the
+ * script writer with the cognitive burden of avoiding it. The price is also
+ * paid by callers of the C interface. The routine
+ *
+ * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr)
+ *
+ * has a guarantee to always return a non-NULL value, but that value points to
+ * a byte sequence that cannot be used by the caller to process the Tcl value
+ * absent some sideband testing that objPtr is "pure". Tcl offers no public
+ * interface to perform this test, so callers either break encapsulation or
+ * are unavoidably buggy. Tcl has defined a public interface that cannot be
+ * used correctly. The Tcl source code itself suffers the same problem, and
+ * has been buggy, but progressively less so as more and more portions of the
+ * code have been retrofitted with the required "purity testing". The set of
+ * values able to pass the purity test can be increased via the introduction
+ * of a "canonical" flag marker, but the only way the broken interface itself
+ * can be discarded is to start over and define the Tcl_ObjType properly.
+ * Bytearrays should simply be usable as bytearrays without a kabuki dance of
+ * testing.
+ *
+ * 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 intrep, as a canonical flag would require.
+ *
+ * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised
+ * to admit the possibility of returning NULL when the true value is not a
+ * valid bytearray, 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 gets used, it's a
+ * signal of a bug being ignored. A TIP should be drafted to remove this
+ * connection to the broken past so that Tcl 9 will no longer have any trace
+ * of it. Prescribing a migration path will be the key element of that work.
+ * The internal changes now in place are the limit of what can be done short
+ * of interface repair. They provide a great expansion of the histories over
+ * which bytearray values can be useful in the meanwhile.
*/
+static const Tcl_ObjType properByteArrayType = {
+ "bytearray",
+ FreeProperByteArrayInternalRep,
+ DupProperByteArrayInternalRep,
+ UpdateStringOfByteArray,
+ NULL
+};
+
const Tcl_ObjType tclByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
- UpdateStringOfByteArray,
+ NULL,
SetByteArrayFromAny
};
@@ -195,9 +267,12 @@ const Tcl_ObjType tclByteArrayType = {
*/
typedef struct ByteArray {
- int used; /* The number of bytes used in the byte
+ unsigned int bad; /* Index of the character that is a nonbyte.
+ * If all characters are bytes, bad = used,
+ * though then we should never read it. */
+ unsigned int used; /* The number of bytes used in the byte
* array. */
- int allocated; /* The amount of space actually allocated
+ unsigned int allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[1]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
@@ -205,12 +280,17 @@ typedef struct ByteArray {
} 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 TclHasIntRep(objPtr, &properByteArrayType);
+}
/*
*----------------------------------------------------------------------
@@ -275,6 +355,7 @@ Tcl_NewByteArrayObj(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
@@ -286,16 +367,25 @@ Tcl_DbNewByteArrayObj(
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);
return objPtr;
+}
#else /* if not 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. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
return Tcl_NewByteArrayObj(bytes, length);
-#endif /* TCL_MEM_DEBUG */
}
+#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
@@ -324,25 +414,83 @@ Tcl_SetByteArrayObj(
* be >= 0. */
{
ByteArray *byteArrayPtr;
+ Tcl_ObjIntRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
- TclFreeIntRep(objPtr);
TclInvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
}
- byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
+ byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ byteArrayPtr->bad = length;
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
if ((bytes != NULL) && (length > 0)) {
- memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+ memcpy(byteArrayPtr->bytes, bytes, length);
+ }
+ SET_BYTEARRAY(&ir, byteArrayPtr);
+
+ Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetBytesFromObj --
+ *
+ * Attempt to extract the value from objPtr in the representation
+ * of a byte sequence. On success return the extracted byte sequence.
+ * On failures, return NULL and record error message and code in
+ * interp (if not NULL).
+ *
+ * Results:
+ * Pointer to array of bytes, or NULL. representing the ByteArray object.
+ * Writes number of bytes in array to *lengthPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+unsigned char *
+TclGetBytesFromObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj *objPtr, /* Value to extract from */
+ int *lengthPtr) /* If non-NULL, filled with length of the
+ * array of bytes in the ByteArray object. */
+{
+ ByteArray *baPtr;
+ const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ if (interp) {
+ const char *nonbyte;
+ int ucs4;
+
+ irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+ baPtr = GET_BYTEARRAY(irPtr);
+ nonbyte = Tcl_UtfAtIndex(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;
+ }
}
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = baPtr->used;
+ }
+ return baPtr->bytes;
}
/*
@@ -370,16 +518,22 @@ Tcl_GetByteArrayFromObj(
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
+ const Tcl_ObjIntRep *irPtr;
+ unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr);
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+ if (result) {
+ return result;
}
- baPtr = GET_BYTEARRAY(objPtr);
+
+ irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+ assert(irPtr != NULL);
+
+ baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
- return (unsigned char *) baPtr->bytes;
+ return baPtr->bytes;
}
/*
@@ -410,22 +564,38 @@ Tcl_SetByteArrayLength(
int length) /* New length for internal byte array. */
{
ByteArray *byteArrayPtr;
+ unsigned newLength;
+ Tcl_ObjIntRep *irPtr;
+
+ assert(length >= 0);
+ newLength = (unsigned int)length;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+
+ irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- if (length > byteArrayPtr->allocated) {
- byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length));
- byteArrayPtr->allocated = length;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ 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;
}
@@ -447,32 +617,48 @@ 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;
+ size_t length, bad;
const char *src, *srcEnd;
unsigned char *dst;
- ByteArray *byteArrayPtr;
Tcl_UniChar ch = 0;
+ ByteArray *byteArrayPtr;
+ Tcl_ObjIntRep ir;
- if (objPtr->typePtr != &tclByteArrayType) {
- src = TclGetStringFromObj(objPtr, &length);
- srcEnd = src + length;
+ if (TclHasIntRep(objPtr, &properByteArrayType)) {
+ return TCL_OK;
+ }
+ if (TclHasIntRep(objPtr, &tclByteArrayType)) {
+ return TCL_OK;
+ }
+
+ src = TclGetString(objPtr);
+ length = bad = objPtr->length;
+ srcEnd = src + length;
- byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
- for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
- src += TclUtfToUniChar(src, &ch);
- *dst++ = UCHAR(ch);
+ 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_StoreIntRep(objPtr, &properByteArrayType, &ir);
+ } else {
+ byteArrayPtr->bad = bad;
+ Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir);
}
+
return TCL_OK;
}
@@ -497,8 +683,14 @@ static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ckfree(GET_BYTEARRAY(objPtr));
- objPtr->typePtr = NULL;
+ ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &tclByteArrayType)));
+}
+
+static void
+FreeProperByteArrayInternalRep(
+ Tcl_Obj *objPtr) /* Object with internal rep to free. */
+{
+ ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &properByteArrayType)));
}
/*
@@ -523,19 +715,43 @@ DupByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- int length;
+ unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjIntRep ir;
- srcArrayPtr = GET_BYTEARRAY(srcPtr);
+ srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
- copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr->bad = srcArrayPtr->bad;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
- memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
- SET_BYTEARRAY(copyPtr, copyArrayPtr);
+ memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
- copyPtr->typePtr = &tclByteArrayType;
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreIntRep(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_ObjIntRep ir;
+
+ srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(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_StoreIntRep(copyPtr, &properByteArrayType, &ir);
}
/*
@@ -543,9 +759,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.
@@ -554,9 +768,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.
- *
*----------------------------------------------------------------------
*/
@@ -565,41 +776,37 @@ UpdateStringOfByteArray(
Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
- int i, length, size;
- unsigned char *src;
- char *dst;
- ByteArray *byteArrayPtr;
-
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- src = byteArrayPtr->bytes;
- length = byteArrayPtr->used;
+ const Tcl_ObjIntRep *irPtr = TclFetchIntRep(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 >= 0; i++) {
+ for (i = 0; i < length && size <= INT_MAX; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
}
}
- if (size < 0) {
+ if (size > INT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- dst = ckalloc(size + 1);
- objPtr->bytes = dst;
- objPtr->length = size;
-
if (size == length) {
- memcpy(dst, src, (size_t) 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';
+ (void) Tcl_InitStringRep(objPtr, NULL, size);
}
}
@@ -629,7 +836,8 @@ TclAppendBytesToByteArray(
int len)
{
ByteArray *byteArrayPtr;
- int needed;
+ unsigned int length, needed;
+ Tcl_ObjIntRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -645,23 +853,34 @@ TclAppendBytesToByteArray(
return;
}
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+
+ length = (unsigned int) len;
+
+ irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
- if (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.
*/
if (needed > byteArrayPtr->allocated) {
ByteArray *ptr = NULL;
- int attempt;
+ unsigned int attempt;
if (needed <= INT_MAX/2) {
/*
@@ -669,7 +888,7 @@ TclAppendBytesToByteArray(
*/
attempt = 2 * needed;
- ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
+ ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
@@ -677,11 +896,11 @@ 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;
- ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
+ ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
@@ -689,18 +908,19 @@ TclAppendBytesToByteArray(
*/
attempt = needed;
- ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
+ ptr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
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;
}
/*
@@ -750,7 +970,7 @@ TclInitBinaryCmd(
static int
BinaryFormatCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -945,7 +1165,7 @@ BinaryFormatCmd(
resultPtr = Tcl_NewObj();
buffer = Tcl_SetByteArrayLength(resultPtr, length);
- memset(buffer, 0, (size_t) length);
+ memset(buffer, 0, length);
/*
* Pack the data into the result object. Note that we can skip the error
@@ -982,10 +1202,10 @@ BinaryFormatCmd(
count = 1;
}
if (length >= count) {
- memcpy(cursor, bytes, (size_t) count);
+ memcpy(cursor, bytes, count);
} else {
- memcpy(cursor, bytes, (size_t) length);
- memset(cursor + length, pad, (size_t) (count - length));
+ memcpy(cursor, bytes, length);
+ memset(cursor + length, pad, count - length);
}
cursor += count;
break;
@@ -1174,7 +1394,7 @@ BinaryFormatCmd(
if (count == BINARY_NOCOUNT) {
count = 1;
}
- memset(cursor, 0, (size_t) count);
+ memset(cursor, 0, count);
cursor += count;
break;
case 'X':
@@ -1222,11 +1442,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;
@@ -1255,7 +1475,7 @@ BinaryFormatCmd(
int
BinaryScanCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1273,9 +1493,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;
@@ -1577,7 +1796,7 @@ BinaryScanCmd(
*/
done:
- Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3));
DeleteScanNumberCache(numberCachePtr);
return TCL_OK;
@@ -1592,11 +1811,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;
@@ -1806,8 +2025,8 @@ CopyNumber(
memcpy(to, from, length);
break;
case 1: {
- const unsigned char *fromPtr = from;
- unsigned char *toPtr = to;
+ const unsigned char *fromPtr = (const unsigned char *)from;
+ unsigned char *toPtr = (unsigned char *)to;
switch (length) {
case 4:
@@ -1830,8 +2049,8 @@ CopyNumber(
break;
}
case 2: {
- const unsigned char *fromPtr = from;
- unsigned char *toPtr = to;
+ const unsigned char *fromPtr = (const unsigned char *)from;
+ unsigned char *toPtr = (unsigned char *)to;
toPtr[0] = fromPtr[4];
toPtr[1] = fromPtr[5];
@@ -1844,8 +2063,8 @@ CopyNumber(
break;
}
case 3: {
- const unsigned char *fromPtr = from;
- unsigned char *toPtr = to;
+ const unsigned char *fromPtr = (const unsigned char *)from;
+ unsigned char *toPtr = (unsigned char *)to;
toPtr[0] = fromPtr[3];
toPtr[1] = fromPtr[2];
@@ -1885,7 +2104,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;
@@ -1901,10 +2119,11 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType);
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
@@ -1920,10 +2139,12 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType);
+
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
/*
@@ -1947,7 +2168,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)) {
@@ -1977,19 +2198,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;
@@ -1999,15 +2220,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;
@@ -2015,10 +2236,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:
@@ -2144,18 +2365,18 @@ ScanNumber(
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
} else {
- register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
- register Tcl_HashEntry *hPtr;
+ Tcl_HashTable *tablePtr = *numberCachePtrPtr;
+ Tcl_HashEntry *hPtr;
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
- return Tcl_GetHashValue(hPtr);
+ return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
- register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
+ Tcl_Obj *objPtr = Tcl_NewWideIntObj(value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, objPtr);
@@ -2173,7 +2394,7 @@ ScanNumber(
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
}
/*
@@ -2207,8 +2428,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);
@@ -2274,7 +2496,7 @@ DeleteScanNumberCache(
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
- register Tcl_Obj *value = Tcl_GetHashValue(hEntry);
+ Tcl_Obj *value = (Tcl_Obj *)Tcl_GetHashValue(hEntry);
if (value != NULL) {
Tcl_DecrRefCount(value);
@@ -2320,7 +2542,7 @@ DeleteScanNumberCache(
static int
BinaryEncodeHex(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2364,7 +2586,7 @@ BinaryEncodeHex(
static int
BinaryDecodeHex(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2372,8 +2594,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 };
@@ -2394,9 +2616,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);
@@ -2409,7 +2634,7 @@ BinaryDecodeHex(
}
c = *data++;
- if (!isxdigit((int) c)) {
+ if (!isxdigit(UCHAR(c))) {
if (strict || !TclIsSpaceProc(c)) {
goto badChar;
}
@@ -2442,14 +2667,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;
}
@@ -2485,7 +2710,7 @@ BinaryDecodeHex(
static int
BinaryEncode64(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2523,12 +2748,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;
}
@@ -2608,7 +2832,7 @@ BinaryEncode64(
static int
BinaryEncodeUu(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2756,7 +2980,7 @@ BinaryEncodeUu(
static int
BinaryDecodeUu(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2764,9 +2988,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 };
@@ -2787,9 +3011,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);
@@ -2896,13 +3123,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;
@@ -2926,7 +3153,7 @@ BinaryDecodeUu(
static int
BinaryDecode64(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2935,9 +3162,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 };
@@ -2958,9 +3185,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);
@@ -3062,19 +3292,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 9c3cbff..c1a585e 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -34,14 +34,14 @@
*/
typedef struct MemTag {
- int refCount; /* Number of mem_headers referencing this
+ size_t refCount; /* Number of mem_headers referencing this
* tag. */
char string[1]; /* 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) + 1) + bytesInString))
+#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1) + bytesInString)
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
@@ -52,14 +52,14 @@ 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
@@ -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 unsigned int total_mallocs = 0;
+static unsigned int 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 unsigned int current_malloc_packets = 0;
+static unsigned int maximum_malloc_packets = 0;
+static unsigned int break_on_malloc = 0;
+static unsigned int trace_on_at_malloc = 0;
static int alloc_tracing = FALSE;
static int init_malloced_bodies = TRUE;
#ifdef MEM_VALIDATE
@@ -131,10 +131,12 @@ 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 int CheckmemCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int MemoryCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static void ValidateMemory(struct mem_header *memHeaderP,
const char *file, int line, int nukeGuards);
@@ -145,7 +147,7 @@ static void ValidateMemory(struct mem_header *memHeaderP,
*
* 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 +158,7 @@ TclInitDbCkalloc(void)
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
-#ifndef TCL_THREADS
+#if !TCL_THREADS
/* Silence compiler warning */
(void)ckallocMutexPtr;
#endif
@@ -184,18 +186,18 @@ TclDumpMemoryInfo(
return 0;
}
sprintf(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 %10u\n"
+ "total frees %10u\n"
+ "current packets allocated %10u\n"
+ "current bytes allocated %10" TCL_Z_MODIFIER "u\n"
+ "maximum packets allocated %10u\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 {
@@ -251,10 +253,10 @@ ValidateMemory(
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "low guard failed at %lx, %s %d\n",
- (long unsigned) memHeaderP->body, file, line);
+ 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");
}
@@ -273,10 +275,10 @@ ValidateMemory(
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "high guard failed at %lx, %s %d\n",
- (long unsigned) memHeaderP->body, file, line);
+ 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 +361,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",
- (long unsigned) address,
- (long unsigned) 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);
@@ -406,7 +407,7 @@ Tcl_DbCkalloc(
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) {
- result = (struct mem_header *) TclpAlloc((unsigned)size +
+ result = (struct mem_header *) TclpAlloc(size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
@@ -450,7 +451,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 (%u)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
@@ -458,14 +459,14 @@ Tcl_DbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (long unsigned int) 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 (%u)", total_mallocs);
}
current_malloc_packets++;
@@ -496,7 +497,7 @@ Tcl_AttemptDbCkalloc(
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
- result = (struct mem_header *) TclpAlloc((unsigned)size +
+ result = (struct mem_header *) TclpAlloc(size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
@@ -547,8 +548,8 @@ Tcl_AttemptDbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (long unsigned int) 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)) {
@@ -612,8 +613,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
- fprintf(stderr, "ckfree %lx %ld %s %d\n",
- (long unsigned int) 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) {
@@ -623,7 +624,7 @@ Tcl_DbCkfree(
Tcl_MutexLock(ckallocMutexPtr);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
- memset(ptr, GUARD_VALUE, (size_t) memp->length);
+ memset(ptr, GUARD_VALUE, memp->length);
}
total_frees++;
@@ -631,9 +632,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 +650,7 @@ Tcl_DbCkfree(
if (allocHead == memp) {
allocHead = memp->flink;
}
- TclpFree((char *) memp);
+ TclpFree(memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
@@ -675,7 +675,7 @@ Tcl_DbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -689,11 +689,11 @@ 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);
- memcpy(newPtr, ptr, (size_t) copySize);
+ memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
@@ -706,7 +706,7 @@ Tcl_AttemptDbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -720,14 +720,14 @@ 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);
if (newPtr == NULL) {
return NULL;
}
- memcpy(newPtr, ptr, (size_t) copySize);
+ memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
@@ -808,13 +808,12 @@ Tcl_AttemptRealloc(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
MemoryCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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 +821,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 +839,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) {
+ int value;
+ if (objc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ break_on_malloc = (unsigned int) 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 %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\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 +893,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 +907,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) {
+ int value;
+ if (objc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
+ if (Tcl_GetIntFromObj(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 +980,23 @@ MemoryCmd(
*
*----------------------------------------------------------------------
*/
+static int CheckmemCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int
CheckmemCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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 +1022,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 +1051,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 +1075,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 +1099,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 +1127,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 +1142,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 +1167,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 +1202,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 +1218,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(ClientData),
+ TCL_UNUSED(int) /*flags*/)
{
- (void)clientData;
- (void)flags;
return 1;
}
@@ -1316,7 +1280,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 01058f5..baaa568 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -109,7 +109,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) */
@@ -275,9 +275,9 @@ TclClockInit(
* Create the client data, which is a refcounted literal pool.
*/
- data = ckalloc(sizeof(ClockClientData));
+ data = (ClockClientData *)ckalloc(sizeof(ClockClientData));
data->refCount = 0;
- data->literals = ckalloc(LIT__END * sizeof(Tcl_Obj*));
+ data->literals = (Tcl_Obj **)ckalloc(LIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < LIT__END; ++i) {
data->literals[i] = Tcl_NewStringObj(literals[i], -1);
Tcl_IncrRefCount(data->literals[i]);
@@ -336,7 +336,7 @@ ClockConvertlocaltoutcObjCmd(
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
- ClockClientData *data = clientData;
+ ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
@@ -430,7 +430,7 @@ ClockGetdatefieldsObjCmd(
{
TclDateFields fields;
Tcl_Obj *dict;
- ClockClientData *data = clientData;
+ ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
@@ -452,7 +452,7 @@ ClockGetdatefieldsObjCmd(
* that it isn't.
*/
- if (objv[1]->typePtr == &tclBignumType) {
+ if (TclHasIntRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
@@ -488,27 +488,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;
@@ -584,12 +584,12 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
{
TclDateFields fields;
Tcl_Obj *dict;
- ClockClientData *data = clientData;
+ ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -600,7 +600,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 +610,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -628,7 +628,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);
}
@@ -668,12 +668,12 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
{
TclDateFields fields;
Tcl_Obj *dict;
- ClockClientData *data = clientData;
+ ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -684,7 +684,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 +694,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -712,7 +712,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);
}
@@ -1079,7 +1079,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 +1217,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 +1233,7 @@ GetYearWeekDay(
*/
if (fields->julianDay < temp.julianDay) {
- if (temp.era == BCE) {
+ if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
@@ -1359,10 +1359,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 +1430,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 +1474,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 +1502,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 +1580,7 @@ IsGregorianLeapYear(
{
int year = fields->year;
- if (fields->era == BCE) {
+ if (fields->isBce) {
year = 1 - year;
}
if (year%4 != 0) {
@@ -1645,14 +1645,13 @@ WeekdayOnOrBefore(
int
ClockGetenvObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
const char *varName;
const char *varValue;
- (void)clientData;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
@@ -1693,7 +1692,7 @@ ThreadSafeLocalTime(
* Get a thread-local buffer to hold the returned time.
*/
- struct tm *tmPtr = Tcl_GetThreadData(&tmKey, sizeof(struct tm));
+ struct tm *tmPtr = (struct tm *)Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
@@ -1731,7 +1730,7 @@ ThreadSafeLocalTime(
int
ClockClicksObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
@@ -1745,7 +1744,6 @@ ClockClicksObjCmd(
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
- (void)clientData;
switch (objc) {
case 1:
@@ -1802,13 +1800,12 @@ ClockClicksObjCmd(
int
ClockMillisecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
- (void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -1840,12 +1837,11 @@ ClockMillisecondsObjCmd(
int
ClockMicrosecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(ClientData),
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;
@@ -1879,7 +1875,7 @@ ClockParseformatargsObjCmd(
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
- ClockClientData *dataPtr = clientData;
+ ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj **litPtr = dataPtr->literals;
Tcl_Obj *results[3]; /* Format, locale and timezone */
#define formatObj results[0]
@@ -1992,13 +1988,12 @@ ClockParseformatargsObjCmd(
int
ClockSecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
- (void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -2029,7 +2024,7 @@ ClockSecondsObjCmd(
static void
TzsetIfNecessary(void)
{
- static char* tzWas = INT2PTR(-1); /* Previous value of TZ, protected by
+ static char* tzWas = (char *)INT2PTR(-1); /* Previous value of TZ, protected by
* clockMutex. */
const char *tzIsNow; /* Current value of TZ */
@@ -2041,7 +2036,7 @@ TzsetIfNecessary(void)
if (tzWas != NULL && tzWas != INT2PTR(-1)) {
ckfree(tzWas);
}
- tzWas = ckalloc(strlen(tzIsNow) + 1);
+ tzWas = (char *)ckalloc(strlen(tzIsNow) + 1);
strcpy(tzWas, tzIsNow);
} else if (tzIsNow == NULL && tzWas != NULL) {
tzset();
@@ -2069,7 +2064,7 @@ static void
ClockDeleteCmdProc(
ClientData clientData) /* Opaque pointer to the client data */
{
- ClockClientData *data = clientData;
+ ClockClientData *data = (ClockClientData *)clientData;
int i;
if (data->refCount-- <= 1) {
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 46ee157..056bd47 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -15,7 +15,6 @@
#ifdef _WIN32
# include "tclWinInt.h"
#endif
-#include <locale.h>
/*
* The state structure used by [foreach]. Note that the actual structure has
@@ -46,24 +45,11 @@ struct ForeachState {
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
-static int BadEncodingSubcommand(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int EncodingConvertfromObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int EncodingConverttoObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int EncodingDirsObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int EncodingNamesObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int EncodingSystemObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc EncodingConvertfromObjCmd;
+static Tcl_ObjCmdProc EncodingConverttoObjCmd;
+static Tcl_ObjCmdProc EncodingDirsObjCmd;
+static Tcl_ObjCmdProc EncodingNamesObjCmd;
+static Tcl_ObjCmdProc EncodingSystemObjCmd;
static inline int ForeachAssignments(Tcl_Interp *interp,
struct ForeachState *statePtr);
static inline void ForeachCleanup(Tcl_Interp *interp,
@@ -84,7 +70,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;
@@ -132,10 +117,9 @@ static Tcl_ObjCmdProc PathTypeCmd;
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_BreakObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -164,16 +148,15 @@ Tcl_BreakObjCmd(
*
*----------------------------------------------------------------------
*/
-
- /* ARGSUSED */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
int
Tcl_CaseObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- register int i;
+ int i;
int body, result, caseObjc;
const char *stringPtr, *arg;
Tcl_Obj *const *caseObjv;
@@ -282,6 +265,7 @@ Tcl_CaseObjCmd(
return TCL_OK;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -300,20 +284,19 @@ Tcl_CaseObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_CatchObjCmd(
- 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, TclNRCatchObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, clientData, objc, objv);
}
int
TclNRCatchObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -353,8 +336,8 @@ CatchObjCmdCallback(
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
- Tcl_Obj *varNamePtr = data[1];
- Tcl_Obj *optionVarNamePtr = data[2];
+ Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1];
+ Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2];
int rewind = iPtr->execEnvPtr->rewind;
/*
@@ -385,7 +368,7 @@ CatchObjCmdCallback(
}
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
@@ -406,10 +389,9 @@ CatchObjCmdCallback(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_CdObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -462,10 +444,9 @@ Tcl_CdObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ConcatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -497,10 +478,9 @@ Tcl_ConcatObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ContinueObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -535,9 +515,9 @@ TclInitEncodingCmd(
static const EnsembleImplMap encodingImplMap[] = {
{"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -545,113 +525,6 @@ TclInitEncodingCmd(
}
/*
- *-----------------------------------------------------------------------------
- *
- * TclMakeEncodingCommandSafe --
- *
- * This function hides the unsafe 'dirs' and 'system' subcommands of
- * the "encoding" Tcl command ensemble. It must be called only from
- * TclHideUnsafeCommands.
- *
- * Results:
- * A standard Tcl result
- *
- * Side effects:
- * Adds commands to the table of hidden commands.
- *
- *-----------------------------------------------------------------------------
- */
-
-int
-TclMakeEncodingCommandSafe(
- Tcl_Interp* interp) /* Tcl interpreter */
-{
- static const struct {
- const char *cmdName;
- int unsafe;
- } unsafeInfo[] = {
- {"convertfrom", 0},
- {"convertto", 0},
- {"dirs", 1},
- {"names", 0},
- {"system", 0},
- {NULL, 0}
- };
-
- 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)));
- }
- Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
- }
- }
- 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.
- */
-
- 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;
-}
-
-/*
*----------------------------------------------------------------------
*
* EncodingConvertfromObjCmd --
@@ -667,7 +540,7 @@ BadEncodingSubcommand(
int
EncodingConvertfromObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -729,7 +602,7 @@ EncodingConvertfromObjCmd(
int
EncodingConverttoObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -793,7 +666,7 @@ EncodingConverttoObjCmd(
int
EncodingDirsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -836,10 +709,11 @@ EncodingDirsObjCmd(
*/
int
-EncodingNamesObjCmd(ClientData dummy, /* Unused */
- Tcl_Interp* interp, /* Tcl interpreter */
- int objc, /* Number of command line args */
- Tcl_Obj* const objv[]) /* Vector of command line args */
+EncodingNamesObjCmd(
+ TCL_UNUSED(ClientData),
+ 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);
@@ -866,10 +740,11 @@ EncodingNamesObjCmd(ClientData dummy, /* Unused */
*/
int
-EncodingSystemObjCmd(ClientData dummy, /* Unused */
- Tcl_Interp* interp, /* Tcl interpreter */
- int objc, /* Number of command line args */
- Tcl_Obj* const objv[]) /* Vector of command line args */
+EncodingSystemObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Number of command line args */
+ Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
@@ -901,10 +776,9 @@ EncodingSystemObjCmd(ClientData dummy, /* Unused */
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ErrorObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -951,10 +825,9 @@ Tcl_ErrorObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
EvalCmdErrMsg(
- ClientData data[],
+ TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
@@ -967,22 +840,22 @@ EvalCmdErrMsg(
int
Tcl_EvalObjCmd(
- 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, TclNREvalObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, clientData, objc, objv);
}
int
TclNREvalObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
int word = 0;
@@ -1034,15 +907,14 @@ TclNREvalObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ExitObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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?");
@@ -1051,11 +923,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);
- /*NOTREACHED*/
+ Tcl_Exit((int)value);
return TCL_OK; /* Better not ever reach this! */
}
@@ -1083,20 +954,19 @@ Tcl_ExitObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ExprObjCmd(
- 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, TclNRExprObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, clientData, objc, objv);
}
int
TclNRExprObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1127,8 +997,8 @@ ExprCallback(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj *resultPtr = data[0];
- Tcl_Obj *objPtr = data[1];
+ Tcl_Obj *resultPtr = (Tcl_Obj *)data[0];
+ Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
if (objPtr != NULL) {
Tcl_DecrRefCount(objPtr);
@@ -1173,40 +1043,41 @@ 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},
+ {"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},
+ {"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);
@@ -1215,141 +1086,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
@@ -1366,7 +1102,7 @@ BadFileSubcommand(
static int
FileAttrAccessTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1392,9 +1128,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;
}
@@ -1443,7 +1184,7 @@ FileAttrAccessTimeCmd(
static int
FileAttrModifyTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1475,7 +1216,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;
}
@@ -1522,7 +1263,7 @@ FileAttrModifyTimeCmd(
static int
FileAttrLinkStatCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1558,7 +1299,7 @@ FileAttrLinkStatCmd(
static int
FileAttrStatCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1594,7 +1335,7 @@ FileAttrStatCmd(
static int
FileAttrTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1632,7 +1373,7 @@ FileAttrTypeCmd(
static int
FileAttrSizeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1669,7 +1410,7 @@ FileAttrSizeCmd(
static int
FileAttrIsDirectoryCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1707,7 +1448,7 @@ FileAttrIsDirectoryCmd(
static int
FileAttrIsExecutableCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1738,7 +1479,7 @@ FileAttrIsExecutableCmd(
static int
FileAttrIsExistingCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1769,7 +1510,7 @@ FileAttrIsExistingCmd(
static int
FileAttrIsFileCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1807,7 +1548,7 @@ FileAttrIsFileCmd(
static int
FileAttrIsOwnedCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1854,7 +1595,7 @@ FileAttrIsOwnedCmd(
static int
FileAttrIsReadableCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1885,7 +1626,7 @@ FileAttrIsReadableCmd(
static int
FileAttrIsWritableCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1916,7 +1657,7 @@ FileAttrIsWritableCmd(
static int
PathDirNameCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1955,7 +1696,7 @@ PathDirNameCmd(
static int
PathExtensionCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1994,7 +1735,7 @@ PathExtensionCmd(
static int
PathRootNameCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2033,7 +1774,7 @@ PathRootNameCmd(
static int
PathTailCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2072,7 +1813,7 @@ PathTailCmd(
static int
PathFilesystemCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2113,7 +1854,7 @@ PathFilesystemCmd(
static int
PathJoinCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2145,7 +1886,7 @@ PathJoinCmd(
static int
PathNativeNameCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2182,7 +1923,7 @@ PathNativeNameCmd(
static int
PathNormalizeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2220,7 +1961,7 @@ PathNormalizeCmd(
static int
PathSplitCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2263,7 +2004,7 @@ PathSplitCmd(
static int
PathTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2311,7 +2052,7 @@ PathTypeCmd(
static int
FilesystemSeparatorCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2321,7 +2062,7 @@ FilesystemSeparatorCmd(
return TCL_ERROR;
}
if (objc == 1) {
- const char *separator = NULL; /* lint */
+ const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
@@ -2366,7 +2107,7 @@ FilesystemSeparatorCmd(
static int
FilesystemVolumesCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2493,7 +2234,7 @@ StoreStatData(
* store in varName. */
{
Tcl_Obj *field, *value;
- register unsigned short mode;
+ unsigned short mode;
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
@@ -2518,23 +2259,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("dev", Tcl_NewWideIntObj((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("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((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)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
@@ -2624,20 +2365,19 @@ GetTypeFromMode(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ForObjCmd(
- 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, TclNRForObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRForObjCmd, clientData, objc, objv);
}
int
TclNRForObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2672,7 +2412,7 @@ ForSetupCallback(
Tcl_Interp *interp,
int result)
{
- ForIterData *iterPtr = data[0];
+ ForIterData *iterPtr = (ForIterData *)data[0];
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -2691,7 +2431,7 @@ TclNRForIterCallback(
Tcl_Interp *interp,
int result)
{
- ForIterData *iterPtr = data[0];
+ ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj;
switch (result) {
@@ -2727,8 +2467,8 @@ ForCondCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- ForIterData *iterPtr = data[0];
- Tcl_Obj *boolObj = data[1];
+ ForIterData *iterPtr = (ForIterData *)data[0];
+ Tcl_Obj *boolObj = (Tcl_Obj *)data[1];
int value;
if (result != TCL_OK) {
@@ -2765,7 +2505,7 @@ ForNextCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- ForIterData *iterPtr = data[0];
+ ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *next = iterPtr->next;
if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
@@ -2789,7 +2529,7 @@ ForPostNextCallback(
Tcl_Interp *interp,
int result)
{
- ForIterData *iterPtr = data[0];
+ ForIterData *iterPtr = (ForIterData *)data[0];
if ((result != TCL_BREAK) && (result != TCL_OK)) {
if (result == TCL_ERROR) {
@@ -2819,20 +2559,19 @@ ForPostNextCallback(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ForeachObjCmd(
- 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, TclNRForeachCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv);
}
int
TclNRForeachCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2842,17 +2581,17 @@ TclNRForeachCmd(
int
Tcl_LmapObjCmd(
- 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, TclNRLmapCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv);
}
int
TclNRLmapCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2870,7 +2609,7 @@ EachloopCmd(
Tcl_Obj *const objv[])
{
int numLists = (objc-2) / 2;
- register struct ForeachState *statePtr;
+ struct ForeachState *statePtr;
int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
@@ -2894,7 +2633,7 @@ EachloopCmd(
* allocation for better performance.
*/
- statePtr = TclStackAlloc(interp,
+ statePtr = (struct ForeachState *)TclStackAlloc(interp,
sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
memset(statePtr, 0,
@@ -2995,7 +2734,7 @@ ForeachLoopStep(
Tcl_Interp *interp,
int result)
{
- register struct ForeachState *statePtr = data[0];
+ struct ForeachState *statePtr = (struct ForeachState *)data[0];
/*
* Process the result code from this run of the [foreach] body. Note that
@@ -3137,10 +2876,9 @@ ForeachCleanup(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FormatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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 e97d495..60331f5 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -56,7 +56,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. */
@@ -99,47 +99,28 @@ typedef struct SortInfo {
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 +137,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 +152,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 +185,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. */
@@ -248,9 +230,9 @@ IfConditionCallback(
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
- Tcl_Obj *const *objv = data[1];
+ Tcl_Obj *const *objv = (Tcl_Obj *const *)data[1];
int i = PTR2INT(data[2]);
- Tcl_Obj *boolObj = data[3];
+ Tcl_Obj *boolObj = (Tcl_Obj *)data[3];
int value, thenScriptIndex = 0;
const char *clause;
@@ -386,7 +368,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. */
@@ -401,7 +383,7 @@ Tcl_IncrObjCmd(
if (objc == 3) {
incrPtr = objv[2];
} else {
- incrPtr = Tcl_NewIntObj(1);
+ incrPtr = Tcl_NewWideIntObj(1);
}
Tcl_IncrRefCount(incrPtr);
newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
@@ -467,12 +449,12 @@ 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. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
const char *name;
Proc *procPtr;
CompiledLocal *localPtr;
@@ -530,15 +512,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. */
{
- register Interp *iPtr = (Interp *) interp;
- const char *name;
+ Interp *iPtr = (Interp *) interp;
+ const char *name, *bytes;
Proc *procPtr;
- Tcl_Obj *bodyPtr, *resultPtr;
+ int numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
@@ -563,18 +545,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 +573,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 +585,7 @@ InfoCmdCountCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount));
return TCL_OK;
}
@@ -643,14 +615,14 @@ 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. */
{
const char *cmdName, *pattern;
const char *simplePattern;
- register Tcl_HashEntry *entryPtr;
+ Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
@@ -718,11 +690,11 @@ InfoCommandsCmd(
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
- cmd = Tcl_GetHashValue(entryPtr);
+ cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
- cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
@@ -749,7 +721,7 @@ InfoCommandsCmd(
entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
}
if (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(tablePtr, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
Tcl_SetObjResult(interp, listPtr);
@@ -765,11 +737,11 @@ InfoCommandsCmd(
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
- cmd = Tcl_GetHashValue(entryPtr);
+ cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
@@ -791,7 +763,7 @@ InfoCommandsCmd(
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) {
@@ -822,7 +794,7 @@ InfoCommandsCmd(
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
@@ -848,7 +820,7 @@ InfoCommandsCmd(
}
entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
@@ -875,7 +847,7 @@ InfoCommandsCmd(
if (!foundGlobal) {
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)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
@@ -920,7 +892,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 +929,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 +967,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
@@ -1004,7 +976,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -1039,7 +1011,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. */
@@ -1054,7 +1026,7 @@ InfoErrorStackCmd(
target = interp;
if (objc == 2) {
- target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ target = Tcl_GetSlave(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
@@ -1088,7 +1060,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. */
@@ -1133,7 +1105,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. */
@@ -1178,7 +1150,7 @@ InfoFrameCmd(
* Just "info frame".
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel));
goto done;
}
@@ -1300,9 +1272,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;
@@ -1320,7 +1292,7 @@ TclInfoFrame(
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
- CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ CmdFrame *fPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*fPtr = *framePtr;
@@ -1339,7 +1311,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) {
@@ -1366,7 +1338,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);
/*
@@ -1402,7 +1374,7 @@ TclInfoFrame(
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
- ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
+ ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData;
int i;
/*
@@ -1416,7 +1388,7 @@ TclInfoFrame(
lv[lc++] =
efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
} else {
- lv[lc++] = efiPtr->fields[i].clientData;
+ lv[lc++] = (Tcl_Obj *)efiPtr->fields[i].clientData;
}
}
}
@@ -1437,7 +1409,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;
}
}
@@ -1473,7 +1445,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. */
@@ -1538,7 +1510,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. */
@@ -1584,7 +1556,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. */
@@ -1592,7 +1564,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;
}
@@ -1658,7 +1630,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. */
@@ -1670,7 +1642,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;
@@ -1705,24 +1677,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 TclGetLoadedPackagesEx(interp, interpName, packageName);
}
/*
@@ -1748,7 +1725,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. */
@@ -1784,7 +1761,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. */
@@ -1796,7 +1773,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));
@@ -1831,7 +1808,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. */
@@ -1845,7 +1822,7 @@ InfoProcsCmd(
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
- register Tcl_HashEntry *entryPtr;
+ Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
@@ -1897,7 +1874,7 @@ InfoProcsCmd(
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
@@ -1922,10 +1899,10 @@ InfoProcsCmd(
{
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
@@ -1968,11 +1945,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);
@@ -2018,12 +1995,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;
@@ -2065,7 +2043,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. */
@@ -2103,7 +2081,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. */
@@ -2127,6 +2105,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 slave 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
@@ -2143,13 +2175,13 @@ 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;
+ int length, listLen;
+ Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
@@ -2166,27 +2198,47 @@ Tcl_JoinObjCmd(
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 */
+ Tcl_SetObjResult(interp, elemPtrs[0]);
+ return TCL_OK;
+ }
+
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- resObjPtr = Tcl_NewObj();
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
+ (void) TclGetStringFromObj(joinObjPtr, &length);
+ if (length == 0) {
+ resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
+ } else {
+ int i;
- /*
- * 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.
- */
+ resObjPtr = Tcl_NewObj();
+ 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);
+ 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;
}
/*
@@ -2208,7 +2260,7 @@ 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. */
@@ -2282,12 +2334,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) {
@@ -2341,9 +2392,9 @@ Tcl_LindexObjCmd(
int
Tcl_LinsertObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
- register int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
@@ -2423,10 +2474,10 @@ Tcl_LinsertObjCmd(
int
Tcl_ListObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
- register int objc, /* Number of arguments. */
- register Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[])
/* The argument objects. */
{
/*
@@ -2459,10 +2510,10 @@ Tcl_ListObjCmd(
int
Tcl_LlengthObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- register Tcl_Obj *const objv[])
+ Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
@@ -2482,7 +2533,108 @@ Tcl_LlengthObjCmd(
* length.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen));
+ 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. */
+{
+ int listLen, 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 = TclListObjGetElements(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;
}
@@ -2505,13 +2657,12 @@ Tcl_LlengthObjCmd(
int
Tcl_LrangeObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- register Tcl_Obj *const objv[])
+ Tcl_Obj *const objv[])
/* Argument objects. */
{
- Tcl_Obj **elemPtrs;
int listLen, first, last, result;
if (objc != 4) {
@@ -2529,55 +2680,148 @@ 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;
+
+ Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+LremoveIndexCompare(
+ const void *el1Ptr,
+ const void *el2Ptr)
+{
+ int idx1 = *((const int *) el1Ptr);
+ int idx2 = *((const int *) 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. */
+{
+ int i, idxc;
+ int listLen, *idxv, prevIdx, first, num;
+ Tcl_Obj *listObj;
+
+ /*
+ * Parse the arguments.
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
+ return TCL_ERROR;
}
- if (first > last) {
- /*
- * Returning an empty list is easy.
- */
+ listObj = objv[1];
+ if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ idxc = objc - 2;
+ if (idxc == 0) {
+ Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
+ idxv = (int *)ckalloc((objc - 2) * sizeof(int));
+ 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(int), 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++) {
+ int 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;
}
@@ -2600,10 +2844,10 @@ Tcl_LrangeObjCmd(
int
Tcl_LrepeatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
- register int objc, /* Number of arguments. */
- register Tcl_Obj *const objv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[])
/* The argument objects. */
{
int elementCount, i, totalElems;
@@ -2668,7 +2912,7 @@ Tcl_LrepeatObjCmd(
CLANG_ASSERT(dataArray || totalElems == 0 );
if (objc == 1) {
- register Tcl_Obj *tmpPtr = objv[0];
+ Tcl_Obj *tmpPtr = objv[0];
tmpPtr->refCount += elementCount;
for (i=0 ; i<elementCount ; i++) {
@@ -2709,12 +2953,12 @@ 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. */
{
- register Tcl_Obj *listPtr;
+ Tcl_Obj *listPtr;
int first, last, listLen, numToDelete, result;
if (objc < 4) {
@@ -2744,7 +2988,7 @@ Tcl_LreplaceObjCmd(
return result;
}
- if (first < 0) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
}
if (first > listLen) {
@@ -2810,7 +3054,7 @@ 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. */
@@ -2889,26 +3133,27 @@ 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;
+ int allocatedIndexVector = 0;
+ int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset;
Tcl_WideInt patWide, objWide;
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 {
@@ -2916,7 +3161,7 @@ Tcl_LsearchObjCmd(
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
@@ -2936,7 +3181,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;
@@ -2954,9 +3201,6 @@ 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;
}
@@ -3021,6 +3265,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
+ startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -3041,25 +3286,47 @@ 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_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (groupSize < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 1", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADSTRIDE", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
int 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;
}
/*
@@ -3071,10 +3338,8 @@ Tcl_LsearchObjCmd(
i++;
if (TclListObjGetElements(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:
@@ -3084,8 +3349,10 @@ Tcl_LsearchObjCmd(
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
- sortInfo.indexv =
+ sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
}
/*
@@ -3096,15 +3363,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;
@@ -3126,14 +3392,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)) {
@@ -3141,7 +3405,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) {
@@ -3167,9 +3432,6 @@ Tcl_LsearchObjCmd(
}
if (regexp == NULL) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3182,24 +3444,64 @@ Tcl_LsearchObjCmd(
result = TclListObjGetElements(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;
}
/*
@@ -3207,16 +3509,21 @@ 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));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
}
- 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);
}
}
@@ -3275,18 +3582,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:
@@ -3375,10 +3687,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);
@@ -3387,7 +3699,7 @@ Tcl_LsearchObjCmd(
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch (mode) {
@@ -3477,22 +3789,27 @@ 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;
- itemPtr = Tcl_NewIntObj(i);
+ itemPtr = Tcl_NewWideIntObj(i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
+ Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
- Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i));
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
@@ -3507,14 +3824,14 @@ Tcl_LsearchObjCmd(
if (returnSubindices) {
int j;
- itemPtr = Tcl_NewIntObj(index);
+ itemPtr = Tcl_NewWideIntObj(index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
+ Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_SetObjResult(interp, itemPtr);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index));
}
} else if (index < 0) {
/*
@@ -3524,7 +3841,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;
@@ -3533,7 +3857,10 @@ Tcl_LsearchObjCmd(
*/
done:
- if (sortInfo.indexc > 1) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
@@ -3558,7 +3885,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. */
@@ -3643,7 +3970,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. */
@@ -3757,13 +4084,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;
@@ -3842,14 +4168,15 @@ Tcl_LsortObjCmd(
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
- sortInfo.indexv =
+ sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
allocatedIndexVector = 1; /* Cannot use indexc field, as it
* might be decreased by 1 later. */
}
for (j=0 ; j<sortInfo.indexc ; j++) {
/* Prescreened values, no errors or out of range possible */
- TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]);
+ TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &sortInfo.indexv[j]);
}
}
@@ -3981,9 +4308,9 @@ Tcl_LsortObjCmd(
elmArrSize = length * sizeof(SortElement);
if (elmArrSize <= MAXCALLOC) {
- elementArray = ckalloc(elmArrSize);
+ elementArray = (SortElement *)ckalloc(elmArrSize);
} else {
- elementArray = malloc(elmArrSize);
+ elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3993,7 +4320,7 @@ Tcl_LsortObjCmd(
goto done;
}
- for (i=0; i < length; i++){
+ for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
@@ -4087,7 +4414,7 @@ Tcl_LsortObjCmd(
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
- objPtr = Tcl_NewIntObj(idx + j - groupOffset);
+ objPtr = Tcl_NewWideIntObj(idx + j - groupOffset);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
} else {
@@ -4099,7 +4426,7 @@ Tcl_LsortObjCmd(
}
} else if (indices) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
- objPtr = Tcl_NewIntObj(elementPtr->payload.index);
+ objPtr = Tcl_NewWideIntObj(elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
@@ -4263,7 +4590,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,
@@ -4449,8 +4776,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;
@@ -4535,9 +4862,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 298b3b7..fe7cddd 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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. */
@@ -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) {
@@ -259,7 +259,7 @@ Tcl_RegexpObjCmd(
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -324,7 +324,7 @@ Tcl_RegexpObjCmd(
if (match == 0) {
/*
- * We want to set the value of the intepreter result only when
+ * We want to set the value of the interpreter result only when
* this is the first time through the loop.
*/
@@ -336,7 +336,7 @@ Tcl_RegexpObjCmd(
*/
if (!doinline) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -389,8 +389,8 @@ Tcl_RegexpObjCmd(
end = -1;
}
- 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 {
@@ -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,
+ 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++) {
@@ -529,6 +530,9 @@ Tcl_RegsubObjCmd(
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) {
@@ -579,14 +583,14 @@ Tcl_RegsubObjCmd(
if (startIndex) {
int stringLength = Tcl_GetCharLength(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,9 +598,9 @@ 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);
@@ -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 (Tcl_ListObjLength(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.
@@ -679,7 +705,9 @@ Tcl_RegsubObjCmd(
} else {
subPtr = objv[2];
}
- wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+ if (!command) {
+ wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+ }
result = TCL_OK;
@@ -738,6 +766,90 @@ Tcl_RegsubObjCmd(
Tcl_AppendUnicodeToObj(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;
+
+ Tcl_ListObjGetElements(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] = Tcl_NewUnicodeObj(
+ wstring + offset + subStart, subEnd - subStart);
+ } else {
+ args[idx + numParts] = Tcl_NewObj();
+ }
+ 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 = Tcl_GetUnicodeFromObj(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) {
+ Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ }
+ offset++;
+ }
+ if (all) {
+ continue;
+ } else {
+ break;
+ }
+ }
+
+ /*
* Append the subSpec argument to the variable, making appropriate
* substitutions. This code is a bit hairy because of the backslash
* conventions and because the code saves up ranges of characters in
@@ -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 = Tcl_GetCharLength(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) {
- register 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 = Tcl_GetCharLength(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. */
@@ -1392,7 +1403,7 @@ StringIndexCmd(
}
/*
- * Get the char length to calulate what 'end' means.
+ * Get the char length to calculate what 'end' means.
*/
length = Tcl_GetCharLength(objv[1]);
@@ -1401,7 +1412,11 @@ StringIndexCmd(
}
if ((index >= 0) && (index < length)) {
- int ch = TclGetUCS4(objv[1], index);
+ int ch = Tcl_GetUniChar(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 = Tcl_GetCharLength(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,19 +1530,19 @@ 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", "wideinteger",
+ "wordchar", "xdigit", NULL
};
enum isClasses {
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_WIDE,
+ STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
@@ -1536,7 +1611,7 @@ StringIsCmd(
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if ((objPtr->typePtr != &tclBooleanType)
+ if (!TclHasIntRep(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 = Tcl_GetCharLength(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 (TclHasIntRep(objPtr, &tclDoubleType) ||
+ TclHasIntRep(objPtr, &tclIntType) ||
+ TclHasIntRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -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 (TclHasIntRep(objPtr, &tclIntType) ||
+ TclHasIntRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1645,7 +1758,6 @@ StringIsCmd(
break;
}
- failedIntParse:
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
@@ -1712,7 +1824,7 @@ StringIsCmd(
const char *elemStart, *nextElem;
int lenRemain, elemSize;
- register const char *p;
+ const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
end = string1 + length1;
@@ -1795,7 +1907,7 @@ StringIsCmd(
str_is_done:
if ((result == 0) && (failVarObj != NULL) &&
- Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
+ Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(failat),
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
@@ -1814,7 +1926,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
/*
@@ -1837,7 +1949,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 +1982,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])
+ && TclHasIntRep(objv[objc-2], &tclDictType)) {
int i, done;
Tcl_DictSearch search;
@@ -1900,7 +2013,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) {
@@ -1969,8 +2082,8 @@ StringMapCmd(
* larger strings.
*/
- int mapLen;
- Tcl_UniChar *mapString, u2lc;
+ int mapLen, u2lc;
+ Tcl_UniChar *mapString;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
@@ -2001,8 +2114,8 @@ StringMapCmd(
}
}
} 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,10 +2124,10 @@ 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],
@@ -2035,7 +2148,7 @@ StringMapCmd(
(Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) &&
/* Restrict max compare length. */
(end-ustring1 >= length2) && ((length2 == 1) ||
- !strCmpFn(ustring2, ustring1, (unsigned) length2))) {
+ !strCmpFn(ustring2, ustring1, length2))) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first.
@@ -2107,7 +2220,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 +2272,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. */
@@ -2215,14 +2328,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 +2351,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((unsigned) 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, (size_t) 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 +2384,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 +2396,20 @@ StringRplcCmd(
return TCL_ERROR;
}
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
+ length = Tcl_GetCharLength(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 +2419,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 +2460,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 +2470,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 +2480,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,12 +2493,12 @@ 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;
+ int ch;
const char *p, *string;
int cur, index, length, numChars;
@@ -2473,7 +2520,7 @@ StringStartCmd(
if (index > 0) {
p = Tcl_UtfAtIndex(string, index);
- TclUtfToUniChar(p, &ch);
+ TclUtfToUCS4(p, &ch);
for (cur = index; cur >= 0; cur--) {
int delta = 0;
const char *next;
@@ -2485,7 +2532,7 @@ StringStartCmd(
next = TclUtfPrev(p, string);
do {
next += delta;
- delta = TclUtfToUniChar(next, &ch);
+ delta = TclUtfToUCS4(next, &ch);
} while (next + delta < p);
p = next;
}
@@ -2493,7 +2540,7 @@ StringStartCmd(
cur += 1;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur));
return TCL_OK;
}
@@ -2503,8 +2550,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,12 +2563,12 @@ 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;
+ int ch;
const char *p, *end, *string;
int cur, index, length, numChars;
@@ -2544,7 +2590,7 @@ StringEndCmd(
p = Tcl_UtfAtIndex(string, index);
end = string+length;
for (cur = index; p < end; cur++) {
- p += TclUtfToUniChar(p, &ch);
+ p += TclUtfToUCS4(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
@@ -2555,7 +2601,7 @@ StringEndCmd(
} else {
cur = numChars;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur));
return TCL_OK;
}
@@ -2579,7 +2625,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 +2637,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 +2647,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 +2700,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,191 +2720,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; -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)) {
- s1 = value1Ptr->bytes;
- s2 = value2Ptr->bytes;
- memCmpFn = memcmp;
- } else {
- s1 = (char *) Tcl_GetUnicode(value1Ptr);
- s2 = (char *) Tcl_GetUnicode(value2Ptr);
- if (
-#ifdef WORDS_BIGENDIAN
- 1
-#else
- checkEq
-#endif /* WORDS_BIGENDIAN */
- ) {
- memCmpFn = memcmp;
- s1len *= sizeof(Tcl_UniChar);
- s2len *= 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) {
- /*
- * 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);
- }
- }
- }
-
- length = (s1len < s2len) ? s1len : s2len;
- if (reqlength > 0 && reqlength < length) {
- length = reqlength;
- } else if (reqlength < 0) {
- /*
- * The requested length is negative, so we ignore it by setting it to
- * length + 1 so we correct the match var.
- */
-
- reqlength = length + 1;
- }
-
- if (checkEq && (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, (size_t) 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. */
@@ -2921,12 +2788,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) {
@@ -2936,23 +2802,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;
}
/*
@@ -2973,10 +2831,9 @@ StringCatCmd(
*
*----------------------------------------------------------------------
*/
-
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. */
@@ -2989,7 +2846,7 @@ StringBytesCmd(
}
(void) TclGetStringFromObj(objv[1], &length);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(length));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
return TCL_OK;
}
@@ -3013,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. */
@@ -3023,7 +2880,7 @@ StringLenCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1])));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1])));
return TCL_OK;
}
@@ -3047,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. */
@@ -3132,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. */
@@ -3217,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. */
@@ -3302,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. */
@@ -3349,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. */
@@ -3395,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. */
@@ -3454,6 +3311,7 @@ TclInitStringCmd(
{"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},
@@ -3537,17 +3395,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. */
@@ -3585,16 +3443,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. */
@@ -3626,7 +3484,7 @@ TclNRSwitchObjCmd(
OPT_LAST
};
typedef int (*strCmpFn_t)(const char *, const char *);
- strCmpFn_t strCmpFn = strcmp;
+ strCmpFn_t strCmpFn = TclUtfCmp;
mode = OPT_EXACT;
foundmode = 0;
@@ -3750,7 +3608,7 @@ TclNRSwitchObjCmd(
Tcl_Obj **listv;
blist = objv[0];
- if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
+ if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
@@ -3912,10 +3770,10 @@ 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);
+ rangeObjAry[0] = Tcl_NewWideIntObj(info.matches[j].start);
+ rangeObjAry[1] = Tcl_NewWideIntObj(info.matches[j].end-1);
} else {
- rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1);
+ rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1);
}
/*
@@ -3977,7 +3835,7 @@ TclNRSwitchObjCmd(
*/
matchFound:
- ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
@@ -4007,7 +3865,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 {
@@ -4021,7 +3879,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;
@@ -4061,9 +3919,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);
/*
@@ -4115,10 +3973,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. */
@@ -4180,14 +4037,14 @@ 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. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
- register int i, result;
+ int i, result;
int count;
double totalMicroSec;
#ifndef TCL_WIDE_CLICKS
@@ -4278,7 +4135,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. */
@@ -4286,8 +4143,8 @@ Tcl_TimeRateObjCmd(
static double measureOverhead = 0;
/* global measure-overhead */
double overhead = -1; /* given measure-overhead */
- register Tcl_Obj *objPtr;
- register int result, i;
+ Tcl_Obj *objPtr;
+ int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
TclWideMUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
@@ -4301,7 +4158,7 @@ Tcl_TimeRateObjCmd(
* zero (i.e., never < 1) */
unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid
* growth of execution time. */
- register Tcl_WideInt start, middle, stop;
+ Tcl_WideInt start, middle, stop;
#ifndef TCL_WIDE_CLICKS
Tcl_Time now;
#endif /* !TCL_WIDE_CLICKS */
@@ -4399,7 +4256,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]);
@@ -4424,7 +4281,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]);
@@ -4821,17 +4678,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. */
@@ -5034,12 +4891,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];
@@ -5085,8 +4942,9 @@ TryPostBody(
Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
+ int numElems = 0;
- Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info);
+ Tcl_ListObjGetElements(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
@@ -5148,8 +5006,8 @@ TryPostBody(
Tcl_ResetResult(interp);
result = TCL_ERROR;
- Tcl_ListObjLength(NULL, info[3], &dummy);
- if (dummy > 0) {
+ Tcl_ListObjLength(NULL, info[3], &numElems);
+ if (numElems> 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
@@ -5159,7 +5017,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) {
@@ -5252,9 +5110,9 @@ TryPostHandler(
Tcl_Obj *finallyObj;
int finally;
- objv = data[0];
- options = data[1];
- handlerKindObj = data[2];
+ objv = (Tcl_Obj **)data[0];
+ options = (Tcl_Obj *)data[1];
+ handlerKindObj = (Tcl_Obj *)data[2];
finally = PTR2INT(data[3]);
cmdObj = objv[0];
@@ -5336,9 +5194,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.
@@ -5397,17 +5255,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. */
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 607521d..37adcef 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -403,9 +390,9 @@ TclCompileArraySetCmd(
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
- infoPtr = ckalloc(sizeof(ForeachInfo));
+ infoPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo));
infoPtr->numLists = 1;
- infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int));
+ infoPtr->varLists[0] = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) + 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 defintion 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 defintion 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 defintion 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 defintion 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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -910,7 +895,7 @@ TclCompileConcatCmd(
Tcl_ListObjGetElements(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 defintion 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 defintion 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 defintion 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 defintion 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(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
+ duiPtr = (DictUpdateInfo *)ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
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++) {
@@ -2255,11 +2268,11 @@ DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
- unsigned len;
+ size_t len;
- dui1Ptr = clientData;
+ dui1Ptr = (DictUpdateInfo *)clientData;
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
- dui2Ptr = ckalloc(len);
+ dui2Ptr = (DictUpdateInfo *)ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
@@ -2275,10 +2288,10 @@ static void
PrintDictUpdateInfo(
ClientData 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++) {
@@ -2293,10 +2306,10 @@ static void
DisassembleDictUpdateInfo(
ClientData 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 = Tcl_NewObj();
@@ -2331,8 +2344,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2405,8 +2417,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *firstWordPtr;
@@ -2450,8 +2461,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2661,8 +2671,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
@@ -2712,7 +2721,7 @@ CompileEachloopCmd(
*/
numLists = (numWords - 2)/2;
- infoPtr = ckalloc(sizeof(ForeachInfo)
+ infoPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo)
+ (numLists - 1) * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
@@ -2746,7 +2755,7 @@ CompileEachloopCmd(
goto done;
}
- varListPtr = ckalloc(sizeof(ForeachVarList)
+ varListPtr = (ForeachVarList *)ckalloc(sizeof(ForeachVarList)
+ (numVars - 1) * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
@@ -2758,7 +2767,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;
@@ -2877,12 +2886,12 @@ DupForeachInfo(
ClientData 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(sizeof(ForeachInfo)
+ dupPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
@@ -2891,7 +2900,7 @@ DupForeachInfo(
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
- dupListPtr = ckalloc(sizeof(ForeachVarList)
+ dupListPtr = (ForeachVarList *)ckalloc(sizeof(ForeachVarList)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
@@ -2926,7 +2935,7 @@ FreeForeachInfo(
ClientData 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;
@@ -2959,10 +2968,10 @@ static void
PrintForeachInfo(
ClientData 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;
@@ -2999,10 +3008,10 @@ static void
PrintNewForeachInfo(
ClientData 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;
@@ -3029,10 +3038,10 @@ static void
DisassembleForeachInfo(
ClientData 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;
@@ -3076,10 +3085,10 @@ static void
DisassembleNewForeachInfo(
ClientData 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;
@@ -3132,14 +3141,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 defintion 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;
/*
@@ -3163,7 +3171,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);
objv[i] = Tcl_NewObj();
@@ -3195,7 +3203,7 @@ TclCompileFormatCmd(
* literal. Job done.
*/
- bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ bytes = TclGetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
@@ -3266,7 +3274,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,
@@ -3300,7 +3308,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++;
@@ -3457,7 +3465,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;
@@ -3511,7 +3519,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 4207df7..3361d7f 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -27,7 +27,6 @@ static void CompileReturnInternal(CompileEnv *envPtr,
Tcl_Obj *returnOpts);
static int IndexTailVarIfKnown(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-
/*
*----------------------------------------------------------------------
@@ -87,8 +86,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -127,9 +125,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);
}
@@ -166,8 +167,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -270,7 +270,7 @@ TclCompileIfCmd(
jumpIndex = jumpFalseFixupArray.next;
jumpFalseFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- jumpFalseFixupArray.fixup+jumpIndex);
+ jumpFalseFixupArray.fixup + jumpIndex);
}
code = TCL_OK;
}
@@ -317,7 +317,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
@@ -329,7 +329,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.
@@ -412,7 +412,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 preceeding "ifFalse" jump. We moved it's
* target (just after this jump) down three bytes.
@@ -431,7 +431,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);
}
}
}
@@ -469,8 +469,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -587,7 +586,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.
@@ -604,7 +603,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 "*\[?"
@@ -638,11 +637,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -666,8 +664,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -715,8 +712,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -750,8 +746,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -770,8 +765,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -806,8 +800,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -844,8 +837,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -920,7 +912,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);
@@ -960,8 +952,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -997,7 +988,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
@@ -1036,7 +1027,7 @@ TclCompileLassignCmd(
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1064,8 +1055,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1087,8 +1077,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.
@@ -1155,8 +1145,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1241,7 +1230,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;
}
@@ -1269,8 +1258,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1302,8 +1290,7 @@ TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1316,8 +1303,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;
}
/*
@@ -1326,7 +1313,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;
}
@@ -1363,8 +1350,7 @@ TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1406,7 +1392,7 @@ TclCompileLinsertCmd(
CompileWord(envPtr, listTokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1414,12 +1400,12 @@ TclCompileLinsertCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
- TclEmitInstInt4( INST_LIST, i-3, envPtr);
+ TclEmitInstInt4( INST_LIST, i - 3, envPtr);
- if (idx == TCL_INDEX_START) {
+ if (idx == (int)TCL_INDEX_START) {
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else if (idx == TCL_INDEX_END) {
+ } else if (idx == (int)TCL_INDEX_END) {
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
} else {
/*
@@ -1434,15 +1420,15 @@ TclCompileLinsertCmd(
* differ in their interpretation of the "end" index.
*/
- if (idx < TCL_INDEX_END) {
+ if (idx < (int)TCL_INDEX_END) {
idx++;
}
TclEmitInstInt4( INST_OVER, 1, envPtr);
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx-1, envPtr);
+ TclEmitInt4( idx - 1, envPtr);
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
}
@@ -1466,8 +1452,7 @@ TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1481,13 +1466,13 @@ TclCompileLreplaceCmd(
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(listTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
&idx1) != TCL_OK) {
return TCL_ERROR;
}
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;
}
@@ -1503,14 +1488,14 @@ TclCompileLreplaceCmd(
* we must defer to direct evaluation.
*/
- if (idx1 == TCL_INDEX_AFTER) {
- suffixStart = idx1;
- } else if (idx2 == TCL_INDEX_BEFORE) {
+ if (idx1 == (int)TCL_INDEX_NONE) {
+ suffixStart = (int)TCL_INDEX_NONE;
+ } else if (idx2 == (int)TCL_INDEX_NONE) {
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))) {
+ } else if (idx2 == (int)TCL_INDEX_END) {
+ suffixStart = (int)TCL_INDEX_NONE;
+ } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END))
+ || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) {
suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
} else {
return TCL_ERROR;
@@ -1544,11 +1529,11 @@ TclCompileLreplaceCmd(
* and canonicalization side effects.
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
- if (idx1 != TCL_INDEX_START) {
+ if (idx1 != (int)TCL_INDEX_START) {
/* Prefix may not be empty; generate bytecode to push it */
if (emptyPrefix) {
TclEmitOpcode( INST_DUP, envPtr);
@@ -1568,7 +1553,7 @@ TclCompileLreplaceCmd(
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
}
- if (suffixStart == TCL_INDEX_AFTER) {
+ if (suffixStart == (int)TCL_INDEX_NONE) {
TclEmitOpcode( INST_POP, envPtr);
if (emptyPrefix) {
PushStringLiteral(envPtr, "");
@@ -1576,7 +1561,7 @@ TclCompileLreplaceCmd(
} else {
/* Suffix may not be empty; generate bytecode to push it */
TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
if (!emptyPrefix) {
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
}
@@ -1630,8 +1615,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1774,11 +1758,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -1802,8 +1785,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1852,8 +1834,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1874,8 +1855,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1910,8 +1890,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1947,8 +1926,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2008,8 +1986,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2072,8 +2049,7 @@ TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2119,7 +2095,7 @@ TclCompileRegexpCmd(
sawLast++;
i++;
break;
- } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
+ } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) {
nocase = 1;
} else {
/*
@@ -2183,7 +2159,7 @@ TclCompileRegexpCmd(
}
if (!simple) {
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2);
}
/*
@@ -2191,7 +2167,7 @@ TclCompileRegexpCmd(
*/
varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1);
if (simple) {
if (exact && !nocase) {
@@ -2237,8 +2213,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
/*
@@ -2293,8 +2268,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;
}
@@ -2325,7 +2300,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;
@@ -2359,7 +2334,7 @@ TclCompileRegsubCmd(
bytes++;
}
isSimpleGlob:
- for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
switch (*bytes) {
case '\\': case '&':
goto done;
@@ -2373,9 +2348,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:
@@ -2412,8 +2387,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2453,7 +2427,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,
@@ -2504,7 +2478,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.
@@ -2582,7 +2556,7 @@ TclCompileReturnCmd(
*/
if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ CompileWord(envPtr, wordTokenPtr, interp, numWords - 1);
} else {
PushStringLiteral(envPtr, "");
}
@@ -2635,7 +2609,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);
@@ -2664,8 +2638,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2771,8 +2744,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2813,12 +2785,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);
}
@@ -2853,7 +2825,7 @@ TclCompileVariableCmd(
static int
IndexTailVarIfKnown(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Token *varTokenPtr, /* Token representing the variable name */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
@@ -2894,7 +2866,7 @@ IndexTailVarIfKnown(
tailName = TclGetStringFromObj(tailPtr, &len);
if (len) {
- if (*(tailName+len-1) == ')') {
+ if (*(tailName + len - 1) == ')') {
/*
* Possible array: bail out
*/
@@ -2908,7 +2880,7 @@ IndexTailVarIfKnown(
*/
for (p = tailName + len -1; p > tailName; p--) {
- if ((*p == ':') && (*(p-1) == ':')) {
+ if ((*p == ':') && (*(p - 1) == ':')) {
p++;
break;
}
@@ -2945,8 +2917,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2970,8 +2941,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2992,11 +2962,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 31e2c88..81c01e0 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -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 defintion 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 defintion 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 defintion 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 defintion 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 defintion 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 defintion 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 defintion 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_OK;
+ }
+
+ /* 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,7 +505,7 @@ TclCompileStringIsCmd(
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
+ "boolean", "dict", "digit", "double", "entier",
"false", "graph", "integer", "list",
"lower", "print", "punct", "space",
"true", "upper", "wideinteger", "wordchar",
@@ -469,7 +513,7 @@ TclCompileStringIsCmd(
};
enum isClasses {
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_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_WIDE, STR_IS_WORD,
@@ -692,14 +736,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 +748,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);
@@ -756,7 +809,7 @@ TclCompileStringMatchCmd(
}
str = tokenPtr[1].start;
length = tokenPtr[1].size;
- if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
+ if ((length <= 1) || strncmp(str, "-nocase", length)) {
/*
* Fail at run time, not in compilation.
*/
@@ -813,8 +866,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -860,7 +912,7 @@ TclCompileStringMapCmd(
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
- char *bytes;
+ const char *bytes;
int len;
/*
@@ -897,12 +949,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 +968,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -938,7 +989,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 +998,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 +1013,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 +1043,7 @@ TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1012,7 +1062,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 +1071,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 +1090,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 +1099,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 +1142,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 +1195,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 +1215,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 +1241,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1222,8 +1268,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1250,8 +1295,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1354,7 +1398,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 +1415,7 @@ StringClassDesc const tclStringClassTable[] = {
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
- {NULL, NULL}
+ {"", NULL}
};
/*
@@ -1399,8 +1443,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1415,7 +1458,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++) {
objv[objc] = Tcl_NewObj();
@@ -1497,14 +1540,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 +1556,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 +1775,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1908,10 +1950,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 +1991,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 +2012,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 +2060,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 +2104,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 +2133,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 +2352,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 +2376,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;
@@ -2507,8 +2547,8 @@ static ClientData
DupJumptableInfo(
ClientData 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;
@@ -2527,7 +2567,7 @@ static void
FreeJumptableInfo(
ClientData clientData)
{
- JumptableInfo *jtPtr = clientData;
+ JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
ckfree(jtPtr);
@@ -2537,10 +2577,10 @@ static void
PrintJumptableInfo(
ClientData 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 +2588,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++) {
@@ -2566,10 +2606,10 @@ static void
DisassembleJumptableInfo(
ClientData 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_NewObj();
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
@@ -2578,7 +2618,7 @@ DisassembleJumptableInfo(
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));
@@ -2609,8 +2649,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2656,8 +2695,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2760,8 +2798,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
@@ -2797,12 +2834,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;
@@ -2872,7 +2909,7 @@ TclCompileTryCmd(
}
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) {
@@ -2884,7 +2921,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) {
@@ -3063,9 +3100,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;
@@ -3087,12 +3124,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);
@@ -3274,8 +3311,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;
@@ -3298,12 +3335,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);
@@ -3570,8 +3607,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3626,7 +3662,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++;
@@ -3708,8 +3744,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3886,8 +3921,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
@@ -3929,8 +3963,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -4179,8 +4212,7 @@ int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
@@ -4190,8 +4222,7 @@ int
TclCompileNotOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
@@ -4201,8 +4232,7 @@ int
TclCompileAddOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
@@ -4213,8 +4243,7 @@ int
TclCompileMulOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
@@ -4225,8 +4254,7 @@ int
TclCompileAndOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
@@ -4237,8 +4265,7 @@ int
TclCompileOrOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
@@ -4249,8 +4276,7 @@ int
TclCompileXorOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
@@ -4261,8 +4287,7 @@ int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -4292,8 +4317,7 @@ int
TclCompileLshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
@@ -4303,8 +4327,7 @@ int
TclCompileRshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
@@ -4314,8 +4337,7 @@ int
TclCompileModOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
@@ -4325,8 +4347,7 @@ int
TclCompileNeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
@@ -4336,8 +4357,7 @@ int
TclCompileStrneqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
@@ -4347,8 +4367,7 @@ int
TclCompileInOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
@@ -4358,8 +4377,7 @@ int
TclCompileNiOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
@@ -4370,8 +4388,7 @@ int
TclCompileLessOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
@@ -4381,8 +4398,7 @@ int
TclCompileLeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
@@ -4392,8 +4408,7 @@ int
TclCompileGreaterOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
@@ -4403,8 +4418,7 @@ int
TclCompileGeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
@@ -4414,8 +4428,7 @@ int
TclCompileEqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
@@ -4425,19 +4438,57 @@ int
TclCompileStreqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion 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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -4482,8 +4533,7 @@ int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 9c7ab8d..4fb41fc 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -281,7 +281,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 +364,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 +421,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 */
@@ -623,7 +631,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";
@@ -667,7 +675,7 @@ ParseExpr(
do {
if (size <= UINT_MAX/sizeof(OpNode)) {
- newPtr = attemptckrealloc(nodes, size * sizeof(OpNode));
+ newPtr = (OpNode *)attemptckrealloc(nodes, size * sizeof(OpNode));
}
} while ((newPtr == NULL)
&& ((size -= (size - nodesUsed) / 2) > nodesUsed));
@@ -911,7 +919,7 @@ ParseExpr(
break;
case SCRIPT: {
- Tcl_Parse *nestedPtr =
+ Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
@@ -1759,7 +1767,7 @@ ConvertTreeToTokens(
/*
* All the Tcl_Tokens allocated and filled belong to
- * this subexpresion. The first token is the leading
+ * this subexpression. The first token is the leading
* TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer)
* are its components.
*/
@@ -1830,7 +1838,7 @@ Tcl_ParseExpr(
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */
Tcl_Obj *funcList = Tcl_NewObj(); /* 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. */
if (numBytes < 0) {
@@ -2001,6 +2009,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;
}
literal = Tcl_NewObj();
@@ -2027,7 +2064,7 @@ ParseLexeme(
* Example: Inf + luence + () becomes a valid function call.
* [Bug 3401704]
*/
- if (literal->typePtr == &tclDoubleType) {
+ if (TclHasIntRep(literal, &tclDoubleType)) {
const char *p = start;
while (p < end) {
@@ -2066,9 +2103,9 @@ ParseLexeme(
if (Tcl_UtfCharComplete(start, numBytes)) {
scanned = TclUtfToUniChar(start, &ch);
} else {
- char utfBytes[TCL_UTF_MAX];
+ char utfBytes[4];
- memcpy(utfBytes, start, (size_t) numBytes);
+ memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
scanned = TclUtfToUniChar(utfBytes, &ch);
}
@@ -2119,7 +2156,7 @@ TclCompileExpr(
OpNode *opTree = NULL; /* Will point to the tree of operators */
Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions */
int code = ParseExpr(interp, script, numBytes, &opTree, litList,
@@ -2181,7 +2218,6 @@ ExecConstantExprTree(
CompileEnv *envPtr;
ByteCode *byteCodePtr;
int code;
- Tcl_Obj *byteCodeObj = Tcl_NewObj();
NRE_callback *rootPtr = TOP_CB(interp);
/*
@@ -2190,19 +2226,17 @@ ExecConstantExprTree(
* 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;
}
@@ -2270,9 +2304,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);
/*
@@ -2287,13 +2321,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,
@@ -2306,7 +2340,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)
@@ -2379,8 +2413,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);
@@ -2389,8 +2423,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;
@@ -2424,7 +2458,7 @@ CompileExprTree(
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
- int index = TclRegisterNewLiteral(envPtr, bytes, length);
+ int index = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
@@ -2479,11 +2513,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
+ = Tcl_GetStringFromObj(objPtr, &numBytes);
- index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
- objPtr->length);
+ index = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
@@ -2537,7 +2573,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;
@@ -2569,7 +2605,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.
@@ -2595,10 +2631,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;
@@ -2670,7 +2706,7 @@ TclVariadicOpCmd(
int objc,
Tcl_Obj *const objv[])
{
- TclOpCmdClientData *occdPtr = clientData;
+ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
int code;
@@ -2725,7 +2761,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;
@@ -2789,7 +2825,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 ece0cae..9d1c56d 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -659,6 +659,23 @@ 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) */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -666,6 +683,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 +697,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,7 +711,7 @@ 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);
@@ -723,13 +741,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))
/*
*----------------------------------------------------------------------
@@ -768,7 +787,8 @@ TclSetByteCodeFromAny(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- int length, result = TCL_OK;
+ size_t length;
+ int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
@@ -776,14 +796,15 @@ 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;
}
#endif
- stringPtr = TclGetStringFromObj(objPtr, &length);
+ stringPtr = TclGetString(objPtr);
+ length = objPtr->length;
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
@@ -829,7 +850,7 @@ TclSetByteCodeFromAny(
if (Tcl_GetMaster(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,
@@ -871,7 +892,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);
@@ -940,8 +961,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;
}
@@ -970,18 +991,18 @@ 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);
- }
+ ByteCodeGetIntRep(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
@@ -998,7 +1019,26 @@ FreeByteCodeInternalRep(
*/
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;
@@ -1107,7 +1147,7 @@ TclCleanupByteCode(
(char *) codePtr);
if (hePtr) {
- ReleaseCmdWordData(Tcl_GetHashValue(hePtr));
+ ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
@@ -1133,7 +1173,6 @@ TclCleanupByteCode(
static int
IsCompactibleCompileEnv(
- Tcl_Interp *interp,
CompileEnv *envPtr)
{
unsigned char *pc;
@@ -1265,8 +1304,6 @@ Tcl_NRSubstObj(
*
* 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 "substcode" type, and the
@@ -1286,24 +1323,26 @@ CompileSubstObj(
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr = NULL;
- if (objPtr->typePtr == &substCodeType) {
+ ByteCodeGetIntRep(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_StoreIntRep(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 +1350,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++;
@@ -1356,12 +1392,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);
- }
+ ByteCodeGetIntRep(objPtr, &substCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
static void
@@ -1374,14 +1410,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 +1496,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 +1552,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;
@@ -1723,7 +1759,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);
@@ -1795,8 +1831,8 @@ CompileCmdLiteral(
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) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
@@ -1831,8 +1867,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 +1917,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);
@@ -2027,7 +2063,7 @@ CompileCommandTokens(
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
parsePtr->tokenPtr, parsePtr->commandStart,
- parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ parsePtr->numWords, cmdLine,
clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
@@ -2149,7 +2185,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;
@@ -2371,7 +2407,7 @@ TclCompileTokens(
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
- char buffer[TCL_UTF_MAX] = "";
+ char buffer[4] = "";
int i, numObjsToConcat, length, adjust;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
@@ -2407,7 +2443,7 @@ TclCompileTokens(
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
- clPosition = ckalloc(maxNumCL * sizeof(int));
+ clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
@@ -2448,7 +2484,7 @@ TclCompileTokens(
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = ckrealloc(clPosition,
+ clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
@@ -2699,8 +2735,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 defintion of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
@@ -2744,11 +2779,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 intrep 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 intrep.
+ */
+ 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. */
{
@@ -2793,13 +2857,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 {
@@ -2820,40 +2885,18 @@ TclInitByteCodeObj(
p += sizeof(ByteCode);
codePtr->codeStart = p;
- memcpy(p, envPtr->codeStart, (size_t) codeBytes);
+ 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 intrep 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 intrep.
- */
- 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 */
if (exceptArrayBytes > 0) {
codePtr->exceptArrayPtr = (ExceptionRange *) p;
- memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes);
+ memcpy(p, envPtr->exceptArrayPtr, exceptArrayBytes);
} else {
codePtr->exceptArrayPtr = NULL;
}
@@ -2861,7 +2904,7 @@ TclInitByteCodeObj(
p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
if (auxDataArrayBytes > 0) {
codePtr->auxDataArrayPtr = (AuxData *) p;
- memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes);
+ memcpy(p, envPtr->auxDataArrayPtr, auxDataArrayBytes);
} else {
codePtr->auxDataArrayPtr = NULL;
}
@@ -2890,15 +2933,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.
*/
@@ -2911,6 +2945,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.
+ */
+
+ ByteCodeSetIntRep(objPtr, typePtr, codePtr);
+ return codePtr;
}
/*
@@ -2978,7 +3037,8 @@ TclFindCompiledLocal(
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
- localName = Tcl_GetStringFromObj(*varNamePtr, &len);
+ localName = TclGetString(*varNamePtr);
+ len = (*varNamePtr)->length;
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
@@ -2996,7 +3056,7 @@ TclFindCompiledLocal(
char *localName = localPtr->name;
if ((nameBytes == localPtr->nameLength) &&
- (strncmp(name,localName,(unsigned)nameBytes) == 0)) {
+ (strncmp(name, localName, nameBytes) == 0)) {
return i;
}
}
@@ -3010,7 +3070,7 @@ TclFindCompiledLocal(
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
- localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1);
+ localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + nameBytes + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -3028,7 +3088,7 @@ TclFindCompiledLocal(
localPtr->resolveInfo = NULL;
if (name != NULL) {
- memcpy(localPtr->name, name, (size_t) nameBytes);
+ memcpy(localPtr->name, name, nameBytes);
}
localPtr->name[nameBytes] = '\0';
procPtr->numCompiledLocals++;
@@ -3060,7 +3120,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. */
@@ -3074,14 +3134,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.
*/
- unsigned char *newPtr = ckalloc(newBytes);
+ unsigned char *newPtr = (unsigned char *)ckalloc(newBytes);
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
@@ -3141,14 +3201,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;
@@ -3245,7 +3305,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,
@@ -3267,16 +3326,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;
@@ -3345,17 +3404,17 @@ TclCreateExceptRange(
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);
@@ -3458,11 +3517,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);
@@ -3484,11 +3543,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] =
@@ -3711,14 +3770,14 @@ TclCreateAuxData(
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;
@@ -3800,14 +3859,14 @@ TclExpandJumpFixupArray(
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;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 1d657a7..5c1b67c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -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;
/*
@@ -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
+ unsigned int 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
+ unsigned int 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
+ unsigned int 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. */
@@ -514,6 +514,23 @@ typedef struct ByteCode {
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
+
+#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (codePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), (typePtr), &ir); \
+ } while (0)
+
+
+
+#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((objPtr), (typePtr)); \
+ (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to the
@@ -823,8 +840,16 @@ 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
+
/* The last opcode */
-#define LAST_INST_OPCODE 189
+#define LAST_INST_OPCODE 194
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -902,7 +927,7 @@ typedef enum InstStringClassType {
} 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;
@@ -1069,7 +1094,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,
@@ -1098,7 +1122,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
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,
+MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
int length, unsigned int hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
@@ -1123,8 +1147,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,25 +1186,8 @@ 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);
@@ -1234,29 +1242,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.
@@ -1571,9 +1556,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, (int) (sizeof(string "") - 1))
/*
* Macro to advance to the next token; it is more mnemonic than the address
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 2fb3e92..3bdcd38 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -41,13 +41,10 @@ typedef struct QCCD {
* Static functions in this file:
*/
-static int QueryConfigObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- struct Tcl_Obj *const *objv);
-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);
/*
*----------------------------------------------------------------------
@@ -79,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;
@@ -199,7 +196,7 @@ QueryConfigObjCmd(
int objc,
struct 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;
@@ -232,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;
}
@@ -247,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;
}
@@ -326,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);
}
/*
@@ -359,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();
@@ -392,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 052e54c..5dd07e7 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -2744,7 +2744,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- void *dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
@@ -2754,7 +2754,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 037b6e5..c713469 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -23,6 +23,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,7 +53,7 @@ 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 */
@@ -110,7 +119,8 @@ 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 boolValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file,
int line);
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
@@ -122,7 +132,8 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue,
EXTERN Tcl_Obj * Tcl_DbNewListObj(int 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);
@@ -149,9 +160,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,
@@ -190,24 +201,28 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp,
Tcl_Obj *listPtr, int first, int count,
int objc, Tcl_Obj *const objv[]);
/* 49 */
-EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewBooleanObj(int boolValue);
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes,
int length);
/* 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[]);
/* 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);
/* 57 */
-EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
/* 58 */
EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length);
/* 59 */
@@ -216,22 +231,26 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
/* 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,
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);
/* 65 */
EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
int 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);
@@ -252,9 +271,11 @@ 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,
@@ -271,7 +292,7 @@ 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(int argc, const char *const *argv);
/* 84 */
EXTERN int Tcl_ConvertElement(const char *src, char *dst,
int flags);
@@ -282,7 +303,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src,
EXTERN int Tcl_CreateAlias(Tcl_Interp *slave,
const char *slaveCmd, Tcl_Interp *target,
const char *targetCmd, int argc,
- CONST84 char *const *argv);
+ const char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave,
const char *slaveCmd, Tcl_Interp *target,
@@ -313,7 +334,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
/* 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);
@@ -403,16 +425,17 @@ 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,
Tcl_FreeProc *freeProc);
@@ -455,18 +478,19 @@ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
/* 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 *slaveCmd,
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 *slaveCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *objcPtr,
+ const char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
/* 150 */
EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
@@ -485,7 +509,7 @@ EXTERN ClientData 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,12 +520,12 @@ 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 *askInterp,
Tcl_Interp *slaveInterp);
@@ -537,19 +561,20 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp,
/* 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,
@@ -569,11 +594,11 @@ 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(int 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);
@@ -582,7 +607,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
/* 191 */
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket);
/* 192 */
-EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Merge(int argc, const char *const *argv);
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr);
/* 194 */
@@ -596,7 +621,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
int flags);
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags);
+ const char **argv, int flags);
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp,
const char *fileName, const char *modeString,
@@ -618,7 +643,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value,
/* 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);
@@ -648,8 +673,7 @@ 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);
+ const char **startPtr, const char **endPtr);
/* 216 */
EXTERN void Tcl_Release(ClientData clientData);
/* 217 */
@@ -660,7 +684,8 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr);
EXTERN int Tcl_ScanCountedElement(const char *src, int 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 */
@@ -704,37 +729,40 @@ 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,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *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);
/* 248 */
@@ -755,13 +783,15 @@ 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);
@@ -774,7 +804,8 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp,
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 */
@@ -784,7 +815,8 @@ 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")
+ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *procPtr,
ClientData prevClientData);
@@ -803,40 +835,46 @@ 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);
@@ -878,7 +916,7 @@ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc,
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,
@@ -901,7 +939,7 @@ 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 */
@@ -950,30 +988,30 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
Tcl_Event *evPtr, Tcl_QueuePosition position);
/* 320 */
-EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index);
+EXTERN int Tcl_UniCharAtIndex(const char *src, int 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);
/* 325 */
-EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index);
+EXTERN const char * Tcl_UtfAtIndex(const char *src, int index);
/* 326 */
EXTERN int Tcl_UtfCharComplete(const char *src, int length);
/* 327 */
EXTERN int 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 * Tcl_UtfNext(const char *src);
/* 331 */
-EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start);
+EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
@@ -990,7 +1028,8 @@ EXTERN int Tcl_UtfToLower(char *src);
/* 335 */
EXTERN int Tcl_UtfToTitle(char *src);
/* 336 */
-EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr);
+EXTERN int Tcl_UtfToChar16(const char *src,
+ unsigned short *chPtr);
/* 337 */
EXTERN int Tcl_UtfToUpper(char *src);
/* 338 */
@@ -1001,9 +1040,11 @@ EXTERN int 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);
/* 344 */
@@ -1023,22 +1064,25 @@ EXTERN int Tcl_UniCharIsUpper(int ch);
/* 351 */
EXTERN int Tcl_UniCharIsWordChar(int ch);
/* 352 */
-EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr);
+TCL_DEPRECATED("Use Tcl_GetCharLength")
+int Tcl_UniCharLen(const Tcl_UniChar *uniStr);
/* 353 */
-EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs,
+TCL_DEPRECATED("Use Tcl_UtfNcmp")
+int Tcl_UniCharNcmp(const Tcl_UniChar *ucs,
const Tcl_UniChar *uct,
unsigned long numChars);
/* 354 */
-EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
+EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr,
int uniLength, Tcl_DString *dsPtr);
/* 355 */
-EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length,
+EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, int 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);
@@ -1050,7 +1094,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
const char *start, int 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,
@@ -1062,7 +1106,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
const char *start, int 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,
@@ -1108,13 +1152,15 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
/* 380 */
EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 381 */
-EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
+EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
/* 382 */
-EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
/* 383 */
EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
/* 384 */
-EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
+TCL_DEPRECATED("Use Tcl_AppendStringsToObj")
+void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, int length);
/* 385 */
EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp,
@@ -1152,8 +1198,7 @@ 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);
@@ -1161,7 +1206,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(
@@ -1173,7 +1219,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(
@@ -1209,11 +1256,13 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel);
/* 418 */
EXTERN int Tcl_IsChannelExisting(const char *channelName);
/* 419 */
-EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs,
+TCL_DEPRECATED("Use Tcl_UtfNcasecmp")
+int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs,
const Tcl_UniChar *uct,
unsigned long numChars);
/* 420 */
-EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
+TCL_DEPRECATED("Use Tcl_StringCaseMatch")
+int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
const Tcl_UniChar *uniPattern, int nocase);
/* 421 */
EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr,
@@ -1259,13 +1308,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
EXTERN Tcl_UniChar * 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);
/* 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,
@@ -1601,18 +1652,18 @@ EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
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);
@@ -1631,7 +1682,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);
@@ -1816,26 +1867,60 @@ 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 */
-/* 649 */
-EXTERN void TclUnusedStubEntry(void);
+/* 631 */
+EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
+ const char *service, const char *host,
+ unsigned int flags,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData 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_FreeIntRep(Tcl_Obj *objPtr);
+/* 637 */
+EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
+ unsigned int numBytes);
+/* 638 */
+EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr);
+/* 639 */
+EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr,
+ const Tcl_ObjIntRep *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,
+ int size);
+/* 645 */
+EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int endValue, int *indexPtr);
+/* 646 */
+EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr);
+/* 647 */
+EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr,
+ int uniLength, Tcl_DString *dsPtr);
+/* 648 */
+EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length,
+ Tcl_DString *dsPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -1848,7 +1933,7 @@ 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 */
void (*tcl_Free) (char *ptr); /* 4 */
@@ -1885,11 +1970,11 @@ typedef struct TclStubs {
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 boolValue, const char *file, int line); /* 22 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, 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_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_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
@@ -1899,7 +1984,7 @@ typedef struct TclStubs {
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 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 */
@@ -1912,25 +1997,25 @@ typedef struct TclStubs {
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int 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 boolValue); /* 49 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
- Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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_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 boolValue); /* 57 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */
void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
- void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
+ 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, int objc, Tcl_Obj *const objv[]); /* 62 */
- void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
+ 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, 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_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 */
@@ -1939,17 +2024,17 @@ typedef struct TclStubs {
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 */
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 */
+ char * (*tcl_Concat) (int argc, const 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 *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
+ int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, 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 */
@@ -1958,7 +2043,7 @@ typedef struct TclStubs {
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData 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_DEPRECATED_API("") 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 *slaveName, int isSafe); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
@@ -1990,11 +2075,11 @@ typedef struct TclStubs {
void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int 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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
void (*tcl_EventuallyFree) (ClientData 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 */
@@ -2007,25 +2092,25 @@ 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") void (*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 *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
- int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
+ TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
+ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
+ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
ClientData (*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 */
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 *askInterp, Tcl_Interp *slaveInterp); /* 163 */
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
@@ -2045,11 +2130,11 @@ typedef struct TclStubs {
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 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 */
@@ -2057,25 +2142,25 @@ 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) (int 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 */
+ char * (*tcl_Merge) (int 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, int argc, const char **argv, int flags); /* 197 */
Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
void (*tcl_Preserve) (ClientData 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 */
+ const 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 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
@@ -2086,12 +2171,12 @@ 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_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */
void (*tcl_Release) (ClientData 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_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 */
@@ -2101,55 +2186,55 @@ typedef struct TclStubs {
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 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int 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 *pkgName, 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_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_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *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, ClientData clientData); /* 247 */
int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData 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 */
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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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 */
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 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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 */
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 */
@@ -2165,7 +2250,7 @@ typedef struct TclStubs {
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 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
- void (*tcl_ExitThread) (int status); /* 294 */
+ TCL_NORETURN1 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 */
void (*tcl_FinalizeThread) (void); /* 297 */
@@ -2173,7 +2258,7 @@ typedef struct TclStubs {
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 */
@@ -2191,29 +2276,29 @@ typedef struct TclStubs {
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_UniCharAtIndex) (const char *src, int index); /* 320 */
+ int (*tcl_UniCharToLower) (int ch); /* 321 */
+ int (*tcl_UniCharToTitle) (int ch); /* 322 */
+ int (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
- CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
+ const 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 */
+ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
+ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
+ const char * (*tcl_UtfNext) (const char *src); /* 330 */
+ const 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_UtfToChar16) (const char *src, unsigned short *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 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
- CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
- void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
+ 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) (ClientData clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
@@ -2223,18 +2308,18 @@ 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_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */
+ TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */
+ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
+ unsigned short * (*tcl_UtfToChar16DString) (const char *src, int 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_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const 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_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */
int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */
int (*tcl_Chdir) (const char *dirName); /* 366 */
@@ -2252,10 +2337,10 @@ typedef struct TclStubs {
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 */
+ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") 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_DEPRECATED_API("Use Tcl_AppendStringsToObj") void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
@@ -2269,14 +2354,14 @@ typedef struct TclStubs {
int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int 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 */
@@ -2290,8 +2375,8 @@ 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 Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */
+ TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *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 */
@@ -2306,8 +2391,8 @@ typedef struct TclStubs {
int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int 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 */
+ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *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 */
@@ -2390,7 +2475,7 @@ 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 */
+ 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, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */
int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */
@@ -2426,18 +2511,18 @@ typedef struct TclStubs {
void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */
void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *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 */
+ 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, Tcl_WideInt 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 */
@@ -2502,25 +2587,24 @@ 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 (*tclUnusedStubEntry) (void); /* 649 */
+ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData 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_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */
+ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */
+ Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
+ void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *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, int size); /* 644 */
+ int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 645 */
+ int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
+ char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */
+ int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3223,8 +3307,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 \
@@ -3259,10 +3343,10 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UniCharLen) /* 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 \
@@ -3813,48 +3897,59 @@ 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 */
-#define TclUnusedStubEntry \
- (tclStubsPtr->tclUnusedStubEntry) /* 649 */
+#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_FreeIntRep \
+ (tclStubsPtr->tcl_FreeIntRep) /* 636 */
+#define Tcl_InitStringRep \
+ (tclStubsPtr->tcl_InitStringRep) /* 637 */
+#define Tcl_FetchIntRep \
+ (tclStubsPtr->tcl_FetchIntRep) /* 638 */
+#define Tcl_StoreIntRep \
+ (tclStubsPtr->tcl_StoreIntRep) /* 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 */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
-#undef TclUnusedStubEntry
-
#if defined(USE_TCL_STUBS)
# undef Tcl_CreateInterp
# undef Tcl_FindExecutable
# undef Tcl_GetStringResult
# undef Tcl_Init
# undef Tcl_SetPanicProc
-# undef Tcl_SetVar
+# undef Tcl_SetExitProc
# undef Tcl_ObjSetVar2
# undef Tcl_StaticPackage
# 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
@@ -3887,13 +3982,13 @@ extern const TclStubs *tclStubsPtr;
sizeof(char *), msg, flags, indexPtr)
#undef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj(boolValue) \
- Tcl_NewIntObj((boolValue)!=0)
+ Tcl_NewWideIntObj((boolValue)!=0)
#undef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj(boolValue, file, line) \
- Tcl_DbNewLongObj((boolValue)!=0, file, line)
+ Tcl_DbNewWideIntObj((boolValue)!=0, file, line)
#undef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj(objPtr, boolValue) \
- Tcl_SetIntObj((objPtr), (boolValue)!=0)
+ Tcl_SetWideIntObj(objPtr, (boolValue)!=0)
#undef Tcl_SetVar
#define Tcl_SetVar(interp, varName, newValue, flags) \
Tcl_SetVar2(interp, varName, NULL, newValue, flags)
@@ -3915,6 +4010,68 @@ 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, -1))
+#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_UniCharLen
+#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, -1, 0)
+#undef Tcl_GlobalEval
+#define Tcl_GlobalEval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
+#undef Tcl_SaveResult
+#define Tcl_SaveResult(interp, statePtr) \
+ do { \
+ (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \
+ Tcl_IncrRefCount((statePtr)->objResultPtr); \
+ Tcl_SetObjResult(interp, Tcl_NewObj()); \
+ } while(0)
+#undef Tcl_RestoreResult
+#define Tcl_RestoreResult(interp, statePtr) \
+ do { \
+ Tcl_ResetResult(interp); \
+ Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \
+ Tcl_DecrRefCount((statePtr)->objResultPtr); \
+ } while(0)
+#undef Tcl_DiscardResult
+#define Tcl_DiscardResult(statePtr) \
+ Tcl_DecrRefCount((statePtr)->objResultPtr)
+#undef Tcl_SetResult
+#define Tcl_SetResult(interp, result, freeProc) \
+ do { \
+ const char *__result = result; \
+ Tcl_FreeProc *__freeProc = freeProc; \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \
+ 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) && !defined(USE_TCL_STUB_PROCS)
# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
@@ -3925,20 +4082,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;
@@ -3964,15 +4115,73 @@ extern const TclStubs *tclStubsPtr;
# 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_GetUnicode
+#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL)
+#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 <= 3
+# undef Tcl_UniCharToUtfDString
+# define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString
+# undef Tcl_UtfToUniCharDString
+# define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString
+# undef Tcl_UtfToUniChar
+# define Tcl_UtfToUniChar Tcl_UtfToChar16
+#endif
+#if defined(USE_TCL_STUBS)
+# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
+ ? (char *(*)(const wchar_t *, int, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
+ : (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_Char16ToUtfDString)
+# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
+ ? (wchar_t *(*)(const char *, int, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \
+ : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString)
+# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
+ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \
+ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar)
+#else
+# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
+ ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \
+ : (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_Char16ToUtfDString)
+# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
+ ? (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToUniCharDString \
+ : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString)
+# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
+ ? (int (*)(const char *, wchar_t *))Tcl_UtfToChar16 \
+ : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar)
+#endif
+
/*
* Deprecated Tcl procedures:
*/
#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_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
+
+#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX > 3)
+# undef Tcl_UtfCharComplete
+# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
+ ? ((length) >= 4) : tclStubsPtr->tcl_UtfCharComplete((src), (length)))
+#endif
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index a42c123..f63d60d 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -11,7 +11,8 @@
*/
#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 */
+ unsigned int 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 DictSetIntRep(objPtr, dictRepPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (dictRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \
+ } while (0)
+
+#define DictGetIntRep(objPtr, dictRepPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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,13 +222,13 @@ 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;
@@ -265,7 +261,7 @@ DeleteChainTable(
ChainEntry *cPtr;
for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
- Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
TclDecrRefCount(valuePtr);
}
@@ -312,7 +308,7 @@ DeleteChainEntry(
if (cPtr == NULL) {
return 0;
} else {
- Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
TclDecrRefCount(valuePtr);
}
@@ -363,18 +359,19 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = DICT(srcPtr);
- Dict *newDict = ckalloc(sizeof(Dict));
+ Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict));
ChainEntry *cPtr;
+ DictGetIntRep(srcPtr, oldDict);
+
/*
* Copy values across from the old hash table.
*/
InitChainTable(newDict);
for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
- Tcl_Obj *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
- Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ Tcl_Obj *key = (Tcl_Obj *)Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
+ Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
int n;
Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n);
@@ -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;
+ DictSetIntRep(copyPtr, newDict);
}
/*
@@ -425,12 +420,13 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = DICT(dictPtr);
+ Dict *dict;
+
+ DictGetIntRep(dictPtr, dict);
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
- dictPtr->typePtr = NULL;
}
/*
@@ -489,7 +485,7 @@ 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, bytesNeeded = 0;
@@ -501,12 +497,17 @@ UpdateStringOfDict(
* is not exposed by any API function...
*/
- int numElems = dict->table.numEntries * 2;
+ int numElems;
+
+ DictGetIntRep(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;
}
@@ -517,7 +518,7 @@ UpdateStringOfDict(
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- flagPtr = ckalloc(numElems);
+ flagPtr = (char *)ckalloc(numElems);
}
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
/*
@@ -526,7 +527,7 @@ UpdateStringOfDict(
*/
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
- keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded < 0) {
@@ -534,7 +535,7 @@ UpdateStringOfDict(
}
flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
- valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
if (bytesNeeded < 0) {
@@ -550,23 +551,22 @@ 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_GetHashKey(&dict->table, &cPtr->entry);
+ keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
flagPtr[i+1] |= TCL_DONT_QUOTE_HASH;
- valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
- dictPtr->bytes[dictPtr->length] = '\0';
+ (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
ckfree(flagPtr);
@@ -600,7 +600,7 @@ SetDictFromAny(
{
Tcl_HashEntry *hPtr;
int isNew;
- Dict *dict = ckalloc(sizeof(Dict));
+ Dict *dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
@@ -610,7 +610,7 @@ SetDictFromAny(
* the conversion from lists to dictionaries.
*/
- if (objPtr->typePtr == &tclListType) {
+ if (TclHasIntRep(objPtr, &tclListType)) {
int objc, i;
Tcl_Obj **objv;
@@ -625,7 +625,7 @@ SetDictFromAny(
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, objv[i], &isNew);
if (!isNew) {
- Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
/*
* Not really a well-formed dictionary as there are duplicate
@@ -665,10 +665,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),
@@ -681,16 +685,20 @@ 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. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
- Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(keyPtr);
TclDecrRefCount(discardedValue);
@@ -706,13 +714,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;
+ DictSetIntRep(objPtr, dict);
return TCL_OK;
missingValue:
@@ -726,6 +731,23 @@ SetDictFromAny(
ckfree(dict);
return TCL_ERROR;
}
+
+static Dict *
+GetDictFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr)
+{
+ Dict *dict;
+
+ DictGetIntRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetIntRep(dictPtr, dict);
+ }
+ return dict;
+}
/*
*----------------------------------------------------------------------
@@ -770,11 +792,13 @@ TclTraceDictPath(
Dict *dict, *newDict;
int i;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
- return NULL;
+ DictGetIntRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetIntRep(dictPtr, dict);
}
- dict = DICT(dictPtr);
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -809,14 +833,18 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
- tmpObj = Tcl_GetHashValue(hPtr);
- if (tmpObj->typePtr != &tclDictType
- && SetDictFromAny(interp, tmpObj) != TCL_OK) {
- return NULL;
+ tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
+
+ DictGetIntRep(tmpObj, newDict);
+
+ if (newDict == NULL) {
+ if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
+ return NULL;
+ }
}
}
- newDict = DICT(tmpObj);
+ DictGetIntRep(tmpObj, newDict);
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -824,7 +852,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = DICT(tmpObj);
+ DictGetIntRep(tmpObj, newDict);
}
newDict->chain = dictPtr;
@@ -859,17 +887,24 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = DICT(dictObj);
+ Dict *dict;
+
+ DictGetIntRep(dictObj, dict);
+ assert( dict != NULL);
do {
+ dict->refCount++;
TclInvalidateStringRep(dictObj);
+ TclFreeIntRep(dictObj);
+ DictSetIntRep(dictObj, dict);
+
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
}
dict->chain = NULL;
- dict = DICT(dictObj);
+ DictGetIntRep(dictObj, dict);
} while (dict != NULL);
}
@@ -907,19 +942,19 @@ 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++;
+ TclFreeIntRep(dictPtr)
+ DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
- Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
+ Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
@@ -958,18 +993,17 @@ 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;
} else {
- *valuePtrPtr = Tcl_GetHashValue(hPtr);
+ *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
return TCL_OK;
}
@@ -1005,16 +1039,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;
@@ -1046,12 +1077,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;
}
@@ -1098,15 +1128,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;
@@ -1115,10 +1144,10 @@ Tcl_DictObjFirst(
searchPtr->next = cPtr->nextPtr;
dict->refCount++;
if (keyPtrPtr != NULL) {
- *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
- *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
+ *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
}
}
return TCL_OK;
@@ -1167,7 +1196,7 @@ Tcl_DictObjNext(
* If the searh is done; we do no work.
*/
- if (searchPtr->epoch == -1) {
+ if (!searchPtr->epoch) {
*donePtr = 1;
return;
}
@@ -1181,7 +1210,7 @@ Tcl_DictObjNext(
Tcl_Panic("concurrent dictionary modification and search");
}
- cPtr = searchPtr->next;
+ cPtr = (ChainEntry *)searchPtr->next;
if (cPtr == NULL) {
Tcl_DictObjDone(searchPtr);
*donePtr = 1;
@@ -1191,11 +1220,11 @@ Tcl_DictObjNext(
searchPtr->next = cPtr->nextPtr;
*donePtr = 0;
if (keyPtrPtr != NULL) {
- *keyPtrPtr = Tcl_GetHashKey(
+ *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(
&((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
- *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
+ *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
}
}
@@ -1224,8 +1253,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);
@@ -1277,11 +1306,12 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetIntRep(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);
}
@@ -1334,7 +1364,8 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = DICT(dictPtr);
+ DictGetIntRep(dictPtr, dict);
+ assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1375,14 +1406,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;
+ DictSetIntRep(dictPtr, dict);
return dictPtr;
#endif
}
@@ -1414,30 +1443,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;
+ DictSetIntRep(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 *****/
@@ -1461,7 +1494,7 @@ Tcl_DbNewDictObj(
static int
DictCreateCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1511,7 +1544,7 @@ DictCreateCmd(
static int
DictGetCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1587,6 +1620,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(ClientData),
+ 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
@@ -1604,7 +1702,7 @@ DictGetCmd(
static int
DictReplaceCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1618,16 +1716,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]);
}
@@ -1655,7 +1750,7 @@ DictReplaceCmd(
static int
DictRemoveCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1669,16 +1764,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]);
}
@@ -1706,7 +1798,7 @@ DictRemoveCmd(
static int
DictMergeCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1729,8 +1821,7 @@ DictMergeCmd(
*/
targetObj = objv[1];
- if (targetObj->typePtr != &tclDictType
- && SetDictFromAny(interp, targetObj) != TCL_OK) {
+ if (GetDictFromObj(interp, targetObj) == NULL) {
return TCL_ERROR;
}
@@ -1794,7 +1885,7 @@ DictMergeCmd(
static int
DictKeysCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1813,8 +1904,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;
}
@@ -1874,7 +1964,7 @@ DictKeysCmd(
static int
DictValuesCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1934,7 +2024,7 @@ DictValuesCmd(
static int
DictSizeCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1972,7 +2062,7 @@ DictSizeCmd(
static int
DictExistsCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1984,11 +2074,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));
@@ -2016,12 +2104,11 @@ DictExistsCmd(
static int
DictInfoCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Tcl_Obj *dictPtr;
Dict *dict;
char *statsStr;
@@ -2030,12 +2117,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));
@@ -2063,7 +2148,7 @@ DictInfoCmd(
static int
DictIncrCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2096,12 +2181,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) {
/*
@@ -2184,7 +2268,7 @@ DictIncrCmd(
static int
DictLappendCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2238,7 +2322,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
- } else if (dictPtr->bytes != NULL) {
+ } else {
TclInvalidateStringRep(dictPtr);
}
@@ -2271,13 +2355,13 @@ DictLappendCmd(
static int
DictAppendCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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 ...?");
@@ -2300,17 +2384,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);
@@ -2341,7 +2457,7 @@ DictAppendCmd(
static int
DictForNRCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2371,7 +2487,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);
@@ -2441,10 +2557,10 @@ DictForLoopCallback(
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;
@@ -2536,7 +2652,7 @@ DictForLoopCallback(
static int
DictMapNRCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2565,7 +2681,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);
@@ -2645,7 +2761,7 @@ DictMapLoopCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- DictMapStorage *storagePtr = data[0];
+ DictMapStorage *storagePtr = (DictMapStorage *)data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
@@ -2748,7 +2864,7 @@ DictMapLoopCallback(
static int
DictSetCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2808,7 +2924,7 @@ DictSetCmd(
static int
DictUnsetCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2867,7 +2983,7 @@ DictUnsetCmd(
static int
DictFilterCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -3152,7 +3268,7 @@ DictFilterCmd(
static int
DictUpdateCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -3182,7 +3298,7 @@ DictUpdateCmd(
}
if (objPtr == NULL) {
/* ??? */
- Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0);
+ Tcl_UnsetVar2(interp, Tcl_GetString(objv[i+1]), NULL, 0);
} else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(dictPtr);
@@ -3213,8 +3329,8 @@ FinalizeDictUpdate(
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.
@@ -3310,7 +3426,7 @@ FinalizeDictUpdate(
static int
DictWithCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -3364,9 +3480,9 @@ FinalizeDictWith(
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) {
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 94679fe..379b427 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -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 InstNameSetIntRep(objPtr, inst) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.wideValue = (inst); \
+ Tcl_StoreIntRep((objPtr), &instNameType, &ir); \
+ } while (0)
+
+#define InstNameGetIntRep(objPtr, inst) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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];
+
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
+
+ iPtr = (Interp *) *codePtr->interpHandle;
TclNewObj(bufferObj);
- if (codePtr->refCount <= 0) {
+ if (!codePtr->refCount) {
return bufferObj; /* Already freed. */
}
@@ -267,11 +276,9 @@ DisassembleByteCodeObj(
* Print header lines describing the ByteCode.
*/
- sprintf(ptrBuf1, "%p", codePtr);
- sprintf(ptrBuf2, "%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,
@@ -314,10 +321,9 @@ DisassembleByteCodeObj(
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
- sprintf(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;
@@ -533,7 +539,7 @@ FormatInstruction(
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
- register const InstructionDesc *instDesc = &tclInstructionTable[opCode];
+ const InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned pcOffset = pc - codeStart;
int opnd = 0, i, j, numBytes = 1;
@@ -648,7 +654,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);
@@ -800,9 +806,8 @@ TclNewInstNameObj(
{
Tcl_Obj *objPtr = Tcl_NewObj();
- objPtr->typePtr = &tclInstNameType;
- objPtr->internalRep.longValue = (long) inst;
- objPtr->bytes = NULL;
+ TclInvalidateStringRep(objPtr);
+ InstNameSetIntRep(objPtr, (long) inst);
return objPtr;
}
@@ -821,20 +826,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;
+
+ InstNameGetIntRep(objPtr, inst);
- if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
- sprintf(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);
+ sprintf(dst, "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;
}
/*
@@ -853,8 +860,8 @@ PrintSourceToObj(
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
- register const char *p;
- register int i = 0, len;
+ const char *p;
+ int i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
@@ -928,17 +935,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;
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
+
/*
* Get the literals from the bytecode.
*/
@@ -1276,6 +1283,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
+ ByteCode *codePtr;
Method *methodPtr;
if (objc < 2) {
@@ -1294,27 +1302,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;
@@ -1364,8 +1364,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 (!TclHasIntRep(objv[2], &tclByteCodeType) && (TCL_OK
+ != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) {
return TCL_ERROR;
}
codeObjPtr = objv[2];
@@ -1415,7 +1416,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1480,7 +1481,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1557,7 +1558,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));
@@ -1565,7 +1566,7 @@ Tcl_DisassembleObjCmd(
"METHODTYPE", NULL);
return TCL_ERROR;
}
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1593,19 +1594,21 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
+ ByteCodeGetIntRep(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 5c7aab8..ae02821 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -46,7 +46,7 @@ typedef struct {
* 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. */
+ size_t refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
@@ -214,51 +214,22 @@ 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 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 Tcl_EncodingConvertProc TableFromUtfProc;
+static Tcl_EncodingConvertProc TableToUtfProc;
+static size_t unilen(const char *src);
+static Tcl_EncodingConvertProc Utf16ToUtfProc;
+static Tcl_EncodingConvertProc UtfToUtf16Proc;
+static Tcl_EncodingConvertProc UtfToUcs2Proc;
+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 Tcl_EncodingConvertProc UtfIntToUtfExtProc;
+static Tcl_EncodingConvertProc UtfExtToUtfIntProc;
+static Tcl_EncodingConvertProc Iso88591FromUtfProc;
+static Tcl_EncodingConvertProc Iso88591ToUtfProc;
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
@@ -269,6 +240,21 @@ static int Iso88591ToUtfProc(ClientData clientData,
static const Tcl_ObjType encodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
+#define EncodingSetIntRep(objPtr, encoding) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (encoding); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &encodingType, &ir); \
+ } while (0)
+
+#define EncodingGetIntRep(objPtr, encoding) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep ((objPtr), &encodingType); \
+ (encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -295,17 +281,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);
-
+ EncodingGetIntRep(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;
+ EncodingSetIntRep(objPtr, encoding);
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
@@ -325,8 +310,10 @@ static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding((Tcl_Encoding)objPtr->internalRep.twoPtrValue.ptr1);
- objPtr->typePtr = NULL;
+ Tcl_Encoding encoding;
+
+ EncodingGetIntRep(objPtr, encoding);
+ Tcl_FreeEncoding(encoding);
}
/*
@@ -344,7 +331,8 @@ DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr));
+ EncodingSetIntRep(dupPtr, encoding);
}
/*
@@ -555,7 +543,7 @@ TclInitEncodingSubsystem(void)
* properly formed stream.
*/
- type.encodingName = "identity";
+ type.encodingName = NULL;
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
@@ -571,14 +559,39 @@ TclInitEncodingSubsystem(void)
type.clientData = NULL;
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(1);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "ucs-2be";
+ type.clientData = INT2PTR(0);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "ucs-2";
type.clientData = INT2PTR(isLe.c);
Tcl_CreateEncoding(&type);
+ type.toUtfProc = Utf16ToUtfProc;
+ type.fromUtfProc = UtfToUtf16Proc;
+ type.freeProc = NULL;
+ type.nullSize = 2;
+ type.encodingName = "utf-16le";
+ type.clientData = INT2PTR(1);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-16be";
+ type.clientData = INT2PTR(0);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-16";
+ type.clientData = INT2PTR(isLe.c);
+ Tcl_CreateEncoding(&type);
+
+#ifndef TCL_NO_DEPRECATED
+ type.encodingName = "unicode";
+ Tcl_CreateEncoding(&type);
+#endif
+
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
@@ -685,6 +698,7 @@ TclFinalizeEncodingSubsystem(void)
*-------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
const char *
Tcl_GetDefaultEncodingDir(void)
{
@@ -728,6 +742,7 @@ Tcl_SetDefaultEncodingDir(
Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
Tcl_SetEncodingSearchPath(searchPath);
}
+#endif
/*
*-------------------------------------------------------------------------
@@ -833,9 +848,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);
@@ -1033,9 +1045,24 @@ 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 == 1) {
+ encodingPtr->lengthProc = (LengthProc *) strlen;
+ } else {
+ encodingPtr->lengthProc = (LengthProc *) unilen;
+ }
+ encodingPtr->refCount = 1;
+ encodingPtr->hPtr = NULL;
+
+ if (typePtr->encodingName) {
Tcl_HashEntry *hPtr;
int isNew;
- Encoding *encodingPtr;
char *name;
Tcl_MutexLock(&encodingMutex);
@@ -1046,30 +1073,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;
}
@@ -1168,7 +1182,7 @@ 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. */
@@ -1359,7 +1373,7 @@ 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. */
@@ -1450,7 +1464,7 @@ Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
- TclInitSubsystems();
+ Tcl_InitSubsystems();
TclpSetInitialEncodings();
TclpFindExecutable(argv0);
}
@@ -1709,7 +1723,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);
@@ -1835,8 +1849,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)'\\'] = '\\';
}
}
}
@@ -2097,15 +2111,11 @@ LoadEscapeEncoding(
static int
BinaryProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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
@@ -2161,7 +2171,7 @@ BinaryProc(
static int
UtfIntToUtfExtProc(
- ClientData clientData, /* Not used. */
+ ClientData clientData,
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
@@ -2210,7 +2220,7 @@ UtfIntToUtfExtProc(
static int
UtfExtToUtfIntProc(
- ClientData clientData, /* Not used. */
+ ClientData clientData,
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
@@ -2259,7 +2269,7 @@ UtfExtToUtfIntProc(
static int
UtfToUtfProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
@@ -2290,7 +2300,7 @@ UtfToUtfProc(
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
- Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
+ int *chPtr = (int *) statePtr;
if (flags & TCL_ENCODING_START) {
*statePtr = 0;
@@ -2308,10 +2318,10 @@ UtfToUtfProc(
}
dstStart = dst;
- dstEnd = dst + dstLen - ((pureNullMode == 1) ? 4 : TCL_UTF_MAX);
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
- if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ if ((src > srcClose) && (!TclUCS4Complete(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.
@@ -2341,9 +2351,9 @@ UtfToUtfProc(
*dst++ = 0;
*chPtr = 0; /* reset surrogate handling */
src += 2;
- } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
+ } else if (!TclUCS4Complete(src, srcEnd - src)) {
/*
- * Always check before using TclUtfToUniChar. Not doing can so
+ * 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.
*/
@@ -2352,38 +2362,20 @@ UtfToUtfProc(
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
- size_t len = TclUtfToUniChar(src, chPtr);
-
- src += len;
- if ((*chPtr & ~0x7FF) == 0xD800) {
- Tcl_UniChar low;
+ src += TclUtfToUCS4(src, chPtr);
+ if ((*chPtr | 0x7FF) == 0xDFFF) {
/* 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;
+ int low = *chPtr;
+ size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(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++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF);
+ *dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF);
+ *dst++ = (char) ((*chPtr | 0x80) & 0xBF);
+ continue;
}
+ src += len;
+ dst += Tcl_UniCharToUtf(*chPtr, dst);
+ *chPtr = low;
}
dst += Tcl_UniCharToUtf(*chPtr, dst);
}
@@ -2398,7 +2390,7 @@ UtfToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UnicodeToUtfProc --
+ * Utf16ToUtfProc --
*
* Convert from UTF-16 to UTF-8.
*
@@ -2412,16 +2404,12 @@ UtfToUtfProc(
*/
static int
-UnicodeToUtfProc(
+Utf16ToUtfProc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
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
@@ -2497,7 +2485,7 @@ UnicodeToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UtfToUnicodeProc --
+ * UtfToUtf16Proc --
*
* Convert from UTF-8 to UTF-16.
*
@@ -2511,7 +2499,7 @@ UnicodeToUtfProc(
*/
static int
-UtfToUnicodeProc(
+UtfToUtf16Proc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
@@ -2572,7 +2560,7 @@ UtfToUnicodeProc(
src += TclUtfToUniChar(src, chPtr);
if (clientData) {
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr & 0xFF);
*dst++ = (*chPtr >> 8);
@@ -2587,7 +2575,7 @@ UtfToUnicodeProc(
*dst++ = (*chPtr >> 8);
#endif
} else {
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX > 3
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr >> 8);
*dst++ = (*chPtr & 0xFF);
@@ -2612,6 +2600,109 @@ UtfToUnicodeProc(
/*
*-------------------------------------------------------------------------
*
+ * UtfToUcs2Proc --
+ *
+ * Convert from UTF-8 to UCS-2.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+UtfToUcs2Proc(
+ ClientData clientData, /* != NULL means LE, == NUL means BE */
+ 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;
+#if TCL_UTF_MAX <= 3
+ int len;
+#endif
+ Tcl_UniChar ch = 0;
+
+ 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 <= 3
+ src += (len = TclUtfToUniChar(src, &ch));
+ if ((ch >= 0xD800) && (len < 3)) {
+ src += TclUtfToUniChar(src, &ch);
+ ch = 0xFFFD;
+ }
+#else
+ src += TclUtfToUniChar(src, &ch);
+ if (ch > 0xFFFF) {
+ ch = 0xFFFD;
+ }
+#endif
+
+ /*
+ * Need to handle this in a way that won't cause misalignment by
+ * casting dst to a Tcl_UniChar. [Bug 1122671]
+ */
+
+ if (clientData) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = (ch >> 8);
+ } else {
+ *dst++ = (ch >> 8);
+ *dst++ = (ch & 0xFF);
+ }
+ }
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
* TableToUtfProc --
*
* Convert from the encoding specified by the TableEncodingData into
@@ -2633,11 +2724,7 @@ TableToUtfProc(
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
@@ -2746,11 +2833,7 @@ TableFromUtfProc(
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
@@ -2801,12 +2884,16 @@ TableFromUtfProc(
}
len = TclUtfToUniChar(src, &ch);
-#if TCL_UTF_MAX > 4
- /* Unicode chars > +U0FFFF cannot be represented in any table encoding */
+#if TCL_UTF_MAX > 3
+ /*
+ * This prevents a crash condition. More evaluation is required for
+ * full support of int Tcl_UniChar. [Bug 1004065]
+ */
+
if (ch & 0xFFFF0000) {
word = 0;
} else
-#elif TCL_UTF_MAX == 4
+#else
if (!len) {
word = 0;
} else
@@ -2863,15 +2950,11 @@ TableFromUtfProc(
static int
Iso88591ToUtfProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
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
@@ -2947,15 +3030,11 @@ Iso88591ToUtfProc(
static int
Iso88591FromUtfProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
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
@@ -3006,7 +3085,7 @@ Iso88591FromUtfProc(
*/
if (ch > 0xFF
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
@@ -3014,7 +3093,7 @@ Iso88591FromUtfProc(
result = TCL_CONVERT_UNKNOWN;
break;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (len < 3)) len = 4;
#endif
/*
@@ -3649,11 +3728,11 @@ unilen(
static void
InitializeEncodingSearchPath(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
- int i, numDirs, numBytes;
+ int i, numDirs;
Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
@@ -3683,11 +3762,11 @@ InitializeEncodingSearchPath(
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
- bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
+ bytes = TclGetString(searchPathObj);
- *lengthPtr = numBytes;
- *valuePtr = (char *)ckalloc(numBytes + 1);
- memcpy(*valuePtr, bytes, numBytes + 1);
+ *lengthPtr = searchPathObj->length;
+ *valuePtr = (char *)ckalloc(*lengthPtr + 1);
+ memcpy(*valuePtr, bytes, *lengthPtr + 1);
Tcl_DecrRefCount(searchPathObj);
}
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index ea32e8a..3c99631 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -21,8 +21,6 @@ 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,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
@@ -86,22 +84,36 @@ static const Tcl_ObjType ensembleCmdType = {
NULL /* setFromAnyProc */
};
+#define ECRSetIntRep(objPtr, ecRepPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (ecRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
+ } while (0)
+
+#define ECRGetIntRep(objPtr, ecRepPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \
+ (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
- * The internal rep for caching ensemble subcommand lookups and
- * spell corrections.
+ * The internal rep for caching ensemble subcommand lookups and spelling
+ * corrections.
*/
typedef struct {
- int epoch; /* Used to confirm when the data in this
+ unsigned int epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
* structure is a cache of the resolution. */
Tcl_Obj *fix; /* Corrected spelling, if needed. */
- Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand
- * hash table. */
+ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash
+ * table. */
} EnsembleCmdRep;
-
static inline Tcl_Obj *
NewNsObj(
@@ -111,9 +123,8 @@ NewNsObj(
if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
return Tcl_NewStringObj("::", 2);
- } else {
- return Tcl_NewStringObj(nsPtr->fullName, -1);
}
+ return Tcl_NewStringObj(nsPtr->fullName, -1);
}
/*
@@ -140,14 +151,14 @@ NewNsObj(
int
TclNamespaceEnsembleCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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;
@@ -302,7 +313,8 @@ TclNamespaceEnsembleCmd(
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
- Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
+ Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
+ &done);
} while (!done);
if (allocatedMapFlag) {
@@ -336,8 +348,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 +359,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);
@@ -576,7 +588,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]);
}
@@ -650,24 +663,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 +712,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 +740,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 +749,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 +781,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);
@@ -791,7 +798,7 @@ Tcl_SetEnsembleSubcommandList(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
@@ -850,7 +857,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);
@@ -867,7 +874,7 @@ Tcl_SetEnsembleParameterList(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->parameterList;
ensemblePtr->parameterList = paramList;
if (paramList != NULL) {
@@ -926,7 +933,7 @@ 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);
@@ -967,7 +974,7 @@ Tcl_SetEnsembleMappingDict(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
@@ -1025,7 +1032,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);
@@ -1042,7 +1049,7 @@ Tcl_SetEnsembleUnknownHandler(
}
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
@@ -1091,14 +1098,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 +1174,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 +1183,7 @@ Tcl_GetEnsembleSubcommandList(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
@@ -1209,7 +1216,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 +1225,7 @@ Tcl_GetEnsembleParameterList(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
}
@@ -1251,7 +1258,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 +1267,7 @@ Tcl_GetEnsembleMappingDict(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
@@ -1292,7 +1299,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 +1308,7 @@ Tcl_GetEnsembleUnknownHandler(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
@@ -1333,7 +1340,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 +1349,7 @@ Tcl_GetEnsembleFlags(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
@@ -1374,7 +1381,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 +1390,7 @@ Tcl_GetEnsembleNamespace(
return TCL_ERROR;
}
- ensemblePtr = cmdPtr->objClientData;
+ ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
@@ -1424,7 +1431,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 +1439,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 +1478,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;
@@ -1637,7 +1645,7 @@ TclMakeEnsemble(
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
- ckfree((char *) nameParts);
+ ckfree(nameParts);
}
return ensemble;
}
@@ -1645,7 +1653,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,8 +1672,8 @@ TclMakeEnsemble(
*----------------------------------------------------------------------
*/
-static int
-NsEnsembleImplementationCmd(
+int
+TclEnsembleImplementationCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -1682,7 +1690,7 @@ NsEnsembleImplementationCmdNR(
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
@@ -1749,13 +1757,13 @@ NsEnsembleImplementationCmdNR(
* check here, and if we're still valid, we can jump straight to the
* part where we do the invocation of the subcommand.
*/
+ EnsembleCmdRep *ensembleCmd;
- if (subObj->typePtr==&ensembleCmdType){
- EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
-
+ ECRGetIntRep(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);
@@ -1803,11 +1811,11 @@ NsEnsembleImplementationCmdNR(
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) {
@@ -1858,7 +1866,7 @@ NsEnsembleImplementationCmdNR(
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
- prefixObj = Tcl_GetHashValue(hPtr);
+ prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_IncrRefCount(prefixObj);
runResultingSubcommand:
@@ -1979,7 +1987,7 @@ NsEnsembleImplementationCmdNR(
int
TclClearRootEnsemble(
- ClientData data[],
+ TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
@@ -2086,7 +2094,7 @@ TclResetRewriteEnsemble(
static int
FreeER(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **) data[0];
@@ -2123,7 +2131,7 @@ TclSpellFix(
*/
size = iPtr->ensembleRewrite.numRemovedObjs + objc
- - iPtr->ensembleRewrite.numInsertedObjs;
+ - iPtr->ensembleRewrite.numInsertedObjs;
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
@@ -2168,9 +2176,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 *));
@@ -2398,8 +2406,8 @@ MakeCachedEnsembleCommand(
{
EnsembleCmdRep *ensembleCmd;
- if (objPtr->typePtr == &ensembleCmdType) {
- ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ ECRGetIntRep(objPtr, ensembleCmd);
+ if (ensembleCmd) {
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
@@ -2410,10 +2418,8 @@ MakeCachedEnsembleCommand(
* our own.
*/
- TclFreeIntRep(objPtr);
- ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
- objPtr->typePtr = &ensembleCmdType;
+ ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
+ ECRSetIntRep(objPtr, ensembleCmd);
}
/*
@@ -2461,7 +2467,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);
}
@@ -2474,7 +2480,7 @@ static void
DeleteEnsembleConfig(
ClientData clientData)
{
- EnsembleConfig *ensemblePtr = clientData;
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
/*
@@ -2539,9 +2545,10 @@ 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
+ * looks, being a hash mapping from the full 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.
+ * all the full command names to allow for reasonably efficient
+ * unambiguous prefix handling.
*
* Results:
* None.
@@ -2573,7 +2580,7 @@ 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.
@@ -2607,7 +2614,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]);
@@ -2616,7 +2625,10 @@ BuildEnsembleConfig(
continue;
}
- /* Lookup target in the dictionary */
+ /*
+ * Lookup target in the dictionary.
+ */
+
if (mapDict) {
Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
if (target) {
@@ -2628,10 +2640,11 @@ 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).
+ * 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).
*/
+
cmdObj = Tcl_NewStringObj(name, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
@@ -2652,7 +2665,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);
@@ -2678,7 +2691,7 @@ BuildEnsembleConfig(
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,
@@ -2727,7 +2740,7 @@ BuildEnsembleConfig(
*/
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
@@ -2751,16 +2764,16 @@ BuildEnsembleConfig(
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);
}
}
@@ -2814,14 +2827,14 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCmd;
+ ECRGetIntRep(objPtr, ensembleCmd);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
ckfree(ensembleCmd);
- objPtr->typePtr = NULL;
}
/*
@@ -2847,11 +2860,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));
+
+ ECRGetIntRep(objPtr, ensembleCmd);
+ ECRSetIntRep(copyPtr, ensembleCopy);
- copyPtr->typePtr = &ensembleCmdType;
- copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
@@ -2977,7 +2991,7 @@ TclCompileEnsemble(
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!
@@ -3366,8 +3380,8 @@ CompileToInvokedCommand(
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
- char *bytes;
- int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ const char *bytes;
+ int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
/*
* Push the words of the command. Take care; the command words may be
@@ -3379,15 +3393,15 @@ CompileToInvokedCommand(
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);
- PushLiteral(envPtr, bytes, length);
+ bytes = TclGetString(words[i-1]);
+ PushLiteral(envPtr, bytes, words[i-1]->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(
@@ -3408,11 +3422,11 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetString(objPtr);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags);
+ cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 15dd8b5..96d050d 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -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)
@@ -608,10 +608,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 e56c21b..db1f59a 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -37,7 +37,7 @@ typedef struct BgError {
* pending background errors for the interpreter.
*/
-typedef struct ErrAssocData {
+typedef struct {
Tcl_Interp *interp; /* Interpreter in which error occurred. */
Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */
BgError *firstBgPtr; /* First in list of all background errors
@@ -55,7 +55,7 @@ typedef struct ErrAssocData {
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 +100,22 @@ 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 char * VwaitVarProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
static void InvokeExitHandlers(void);
@@ -139,6 +139,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 +148,7 @@ Tcl_BackgroundError(
{
Tcl_BackgroundException(interp, TCL_ERROR);
}
+#endif /* TCL_NO_DEPRECATED */
void
Tcl_BackgroundException(
@@ -160,7 +163,7 @@ Tcl_BackgroundException(
return;
}
- errPtr = ckalloc(sizeof(BgError));
+ errPtr = (BgError*)ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
@@ -168,7 +171,7 @@ Tcl_BackgroundException(
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
- assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
@@ -198,9 +201,9 @@ Tcl_BackgroundException(
static void
HandleBgErrors(
- ClientData clientData) /* Pointer to ErrAssocData structure. */
+ void *clientData) /* Pointer to ErrAssocData structure. */
{
- ErrAssocData *assocPtr = clientData;
+ ErrAssocData *assocPtr = (ErrAssocData *)clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
@@ -227,7 +230,7 @@ HandleBgErrors(
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
- tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
+ tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
@@ -308,7 +311,7 @@ HandleBgErrors(
int
TclDefaultBgErrorHandlerObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -515,7 +518,7 @@ TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
- ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
@@ -525,7 +528,7 @@ TclSetBgErrorHandler(
* First access: initialize.
*/
- assocPtr = ckalloc(sizeof(ErrAssocData));
+ assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
@@ -560,14 +563,14 @@ Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
- ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
- assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
@@ -593,10 +596,10 @@ 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 = clientData;
+ ErrAssocData *assocPtr = (ErrAssocData *)clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
@@ -632,9 +635,9 @@ 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 = ckalloc(sizeof(ExitHandler));
+ ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
@@ -665,9 +668,9 @@ 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 = ckalloc(sizeof(ExitHandler));
+ ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
@@ -698,7 +701,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 +744,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,12 +787,12 @@ 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);
- exitPtr = ckalloc(sizeof(ExitHandler));
+ exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
@@ -817,7 +820,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 +1002,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.
@@ -1022,10 +1025,10 @@ Tcl_Exit(
*/
void
-TclInitSubsystems(void)
+Tcl_InitSubsystems(void)
{
if (inExit != 0) {
- Tcl_Panic("TclInitSubsystems called while exiting");
+ Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
@@ -1048,6 +1051,9 @@ TclInitSubsystems(void)
#if 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
@@ -1222,7 +1228,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
@@ -1290,7 +1296,7 @@ FinalizeThread(
* initialized already.
*/
- tsdPtr = TclThreadDataKeyGet(&dataKey);
+ tsdPtr = (ThreadSpecificData*)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
@@ -1365,7 +1371,7 @@ TclInExit(void)
int
TclInThreadExit(void)
{
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
@@ -1390,10 +1396,9 @@ TclInThreadExit(void)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_VwaitObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1454,19 +1459,18 @@ Tcl_VwaitObjCmd(
return TCL_OK;
}
- /* ARGSUSED */
static char *
VwaitVarProc(
- ClientData clientData, /* Pointer to integer to set to 1. */
+ void *clientData, /* Pointer to integer to set to 1. */
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 = clientData;
+ int *donePtr = (int *)clientData;
*donePtr = 1;
- Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
}
@@ -1488,10 +1492,9 @@ VwaitVarProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_UpdateObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1540,7 +1543,7 @@ Tcl_UpdateObjCmd(
return TCL_OK;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1559,10 +1562,10 @@ Tcl_UpdateObjCmd(
static Tcl_ThreadCreateType
NewThreadProc(
- ClientData clientData)
+ void *clientData)
{
- ThreadClientData *cdPtr = clientData;
- ClientData threadClientData;
+ ThreadClientData *cdPtr = (ThreadClientData *)clientData;
+ void *threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
@@ -1598,13 +1601,13 @@ 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
- ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
+#if TCL_THREADS
+ ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData));
int result;
cdPtr->proc = proc;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 76feb79..cc366e7 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -18,7 +18,7 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
@@ -34,14 +34,14 @@
#endif
/*
- * A mask (should be 2**n-1) that is used to work out when the bytecode engine
- * should call Tcl_AsyncReady() to see whether there is a signal that needs
- * handling.
+ * A counter that is used to work out when the bytecode engine should call
+ * Tcl_AsyncReady() to see whether there is a signal that needs handling, and
+ * other expensive periodic operations.
*/
-#ifndef ASYNC_CHECK_COUNT_MASK
-# define ASYNC_CHECK_COUNT_MASK 63
-#endif /* !ASYNC_CHECK_COUNT_MASK */
+#ifndef ASYNC_CHECK_COUNT
+# define ASYNC_CHECK_COUNT 64
+#endif /* !ASYNC_CHECK_COUNT */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
@@ -97,9 +97,9 @@ static const char *const resultStrings[] = {
*/
#ifdef TCL_COMPILE_STATS
-long tclObjsAlloced = 0;
-long tclObjsFreed = 0;
-long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
+size_t tclObjsAlloced = 0;
+size_t tclObjsFreed = 0;
+size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
@@ -202,7 +202,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 +211,7 @@ typedef struct TEBCdata {
*/
#define VarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static inline Var *
VarHashCreateVar(
@@ -508,55 +508,20 @@ VarHashCreateVar(
* ClientData *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, \
+ ((TclHasIntRep((objPtr), &tclIntType)) \
+ ? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclDoubleType) \
+ TclHasIntRep((objPtr), &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 : \
+ ? 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 *boolPtr);
- */
-
-#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
- ((((objPtr)->typePtr == &tclIntType) \
- || ((objPtr)->typePtr == &tclBooleanType)) \
- ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
- : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -586,40 +551,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 +654,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,6 +662,7 @@ 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:
@@ -754,8 +685,6 @@ 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 +759,22 @@ ReleaseDictIterator(
{
Tcl_DictSearch *searchPtr;
Tcl_Obj *dictPtr;
+ const Tcl_ObjIntRep *irPtr;
+
+ irPtr = TclFetchIntRep(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 +798,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 +806,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 +815,15 @@ InitByteCodeExecution(
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
#endif /* TCL_COMPILE_STATS */
}
+
+#else
+
+static void
+InitByteCodeExecution(
+ TCL_UNUSED(Tcl_Interp *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -913,14 +854,14 @@ TclCreateExecEnv(
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
- ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
- ExecStack *esPtr = ckalloc(sizeof(ExecStack)
+ ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
+ ExecStack *esPtr = (ExecStack *)ckalloc(sizeof(ExecStack)
+ (size_t) (size-1) * 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;
@@ -1183,7 +1124,7 @@ GrowEvaluationStack(
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
- esPtr = ckalloc(newBytes);
+ esPtr = (ExecStack *)ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
@@ -1282,7 +1223,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- ckfree((char *) freePtr);
+ ckfree(freePtr);
return;
}
@@ -1407,7 +1348,7 @@ int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- register 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. */
@@ -1425,11 +1366,11 @@ Tcl_ExprObj(
static int
CopyCallback(
ClientData data[],
- Tcl_Interp *interp,
+ 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;
@@ -1486,8 +1427,8 @@ ExprObjCallback(
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 +1447,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.
@@ -1526,7 +1465,7 @@ CompileExprObj(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- register ByteCode *codePtr = NULL;
+ ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode. Initialized
* to avoid compiler warning. */
@@ -1534,28 +1473,31 @@ CompileExprObj(
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &exprCodeType) {
+
+ ByteCodeGetIntRep(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_StoreIntRep(objPtr, &exprCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &exprCodeType) {
+
+ if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
- int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
+ const char *string = TclGetString(objPtr);
- TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
- TclCompileExpr(interp, string, length, &compEnv, 0);
+ TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
+ TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
@@ -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;
+ ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr);
+ assert(codePtr != NULL);
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
/*
@@ -1680,8 +1619,8 @@ TclCompileObj(
const CmdFrame *invoker,
int word)
{
- register Interp *iPtr = (Interp *) interp;
- register ByteCode *codePtr; /* Tcl Internal type of bytecode. */
+ Interp *iPtr = (Interp *) interp;
+ ByteCode *codePtr; /* Tcl Internal type of bytecode. */
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
/*
@@ -1690,7 +1629,8 @@ TclCompileObj(
* compilation). Otherwise, check that it is "fresh" enough.
*/
- if (objPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetIntRep(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;
+ ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1873,6 +1812,7 @@ TclIncrObj(
ClientData 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 = augend + 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 = w1 + 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;
}
@@ -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
@@ -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 */
@@ -2341,10 +2257,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);
@@ -2558,7 +2475,7 @@ TEBCresume(
/* 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));
+ TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2718,154 +2635,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 accomodate 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, (size_t) 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, (size_t) 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:
/*
@@ -2877,6 +2659,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:
/*
@@ -3810,9 +3593,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
-#endif
long increment;
case INST_INCR_SCALAR1:
@@ -3911,9 +3692,9 @@ TEBCresume(
objPtr = varPtr->value.objPtr;
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
- if (type == TCL_NUMBER_LONG) {
- long augend = *((const long *)ptr);
- long sum = augend + increment;
+ if (type == TCL_NUMBER_INT) {
+ Tcl_WideInt augend = *((const Tcl_WideInt *)ptr);
+ Tcl_WideInt sum = augend + increment;
/*
* Overflow when (augend and sum have different sign) and
@@ -3925,16 +3706,15 @@ 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));
@@ -3951,44 +3731,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 = w + 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 */
@@ -3998,7 +3744,7 @@ TEBCresume(
} else {
objResultPtr = objPtr;
}
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
Tcl_DecrRefCount(incrPtr);
TRACE_ERROR(interp);
@@ -4012,7 +3758,7 @@ TEBCresume(
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
@@ -4397,10 +4143,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 {
@@ -4808,7 +4551,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.
@@ -4836,7 +4579,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
if (oPtr == NULL) {
@@ -4935,7 +4678,7 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
@@ -5098,8 +4841,8 @@ TEBCresume(
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
- && (value2Ptr->typePtr != &tclListType)
- && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
+ && !TclHasIntRep(value2Ptr, &tclListType)
+ && (TclGetIntForIndexM(NULL, value2Ptr, objc-1,
&index) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
tosPtr--;
@@ -5271,11 +5014,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 (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5303,17 +5046,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:
+ objResultPtr = Tcl_NewObj();
+ TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
+ NEXT_INST_F(9, 1, 1);
}
toIdx = TclIndexDecode(toIdx, objc - 1);
if (toIdx < 0) {
@@ -5324,37 +5061,17 @@ 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 subsquence 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);
- }
- } else {
- emptyList:
- TclNewObj(objResultPtr);
- }
+ objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
@@ -5440,6 +5157,10 @@ TEBCresume(
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;
@@ -5470,15 +5191,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;
}
@@ -5571,11 +5296,23 @@ TEBCresume(
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
- char buf[8] = "";
- int ch = TclGetUCS4(valuePtr, index);
+ char buf[4] = "";
+ int ch = Tcl_GetUniChar(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) {
+ objResultPtr = Tcl_NewObj();
+ } 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)));
@@ -5623,17 +5360,13 @@ TEBCresume(
/* Decode index operands. */
/*
- assert ( toIdx != TCL_INDEX_BEFORE );
- assert ( toIdx != TCL_INDEX_AFTER);
+ assert ( toIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
- if (toIdx == TCL_INDEX_BEFORE) {
+ if (toIdx == TCL_INDEX_NONE) {
goto emptyRange;
}
- if (toIdx == TCL_INDEX_AFTER) {
- toIdx = TCL_INDEX_END;
- }
toIdx = TclIndexDecode(toIdx, length - 1);
if (toIdx < 0) {
@@ -5645,17 +5378,13 @@ TEBCresume(
assert ( toIdx >= 0 && toIdx < length );
/*
- assert ( fromIdx != TCL_INDEX_BEFORE );
- assert ( fromIdx != TCL_INDEX_AFTER);
+ assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
- if (fromIdx == TCL_INDEX_BEFORE) {
+ if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
- if (fromIdx == TCL_INDEX_AFTER) {
- goto emptyRange;
- }
fromIdx = TclIndexDecode(fromIdx, length - 1);
if (fromIdx < 0) {
@@ -5718,82 +5447,9 @@ TEBCresume(
NEXT_INST_F(1, 0, 0);
}
- length3 = Tcl_GetCharLength(value3Ptr);
-
- /*
- * See if we can splice in place. This happens when the number of
- * characters being replaced is the same as the number of characters
- * in the string to be inserted.
- */
-
- if (length3 - 1 == toIdx - fromIdx) {
- unsigned char *bytes1, *bytes2;
-
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_DuplicateObj(valuePtr);
- } else {
- objResultPtr = valuePtr;
- }
- if (TclIsPureByteArray(objResultPtr)
- && TclIsPureByteArray(value3Ptr)) {
- bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
- bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
- memcpy(bytes1 + fromIdx, bytes2, length3);
- } else {
- ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
- ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
- memcpy(ustring1 + fromIdx, ustring2,
- length3 * sizeof(Tcl_UniChar));
- }
- Tcl_InvalidateStringRep(objResultPtr);
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- if (objResultPtr == valuePtr) {
- NEXT_INST_F(1, 0, 0);
- } else {
- NEXT_INST_F(1, 1, 1);
- }
- }
-
- /*
- * Get the unicode representation; this is where we guarantee to lose
- * bytearrays.
- */
+ objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
+ toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);
- 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);
@@ -5866,45 +5522,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);
+ 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);
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -5939,8 +5567,8 @@ TEBCresume(
* both.
*/
- if ((valuePtr->typePtr == &tclStringType)
- || (value2Ptr->typePtr == &tclStringType)) {
+ if (TclHasIntRep(valuePtr, &tclStringType)
+ || TclHasIntRep(value2Ptr, &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
@@ -6074,35 +5702,18 @@ TEBCresume(
{
ClientData ptr1, ptr2;
int type1, type2;
- long l1, 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 */
+ /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */
Tcl_WideInt w;
if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
+ type1 = TCL_NUMBER_INT;
}
}
TclNewIntObj(objResultPtr, type1);
@@ -6148,10 +5759,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);
}
@@ -6227,17 +5838,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.
*/
@@ -6246,7 +5857,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.
*/
@@ -6256,25 +5867,25 @@ 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 = l1 - l2*lResult;
- goto longResultOfArithmetic;
+ wResult = w1 - w2*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
@@ -6285,7 +5896,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)));
@@ -6295,7 +5906,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
@@ -6304,7 +5915,7 @@ TEBCresume(
*/
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (l1 > 0L) {
+ if (w1 > 0L) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
@@ -6317,13 +5928,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
@@ -6334,12 +5945,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
@@ -6357,17 +5968,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>0 ? l1 : ~l1) &
+ if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0)
+ && !((w1>0 ? w1 : ~w1) &
-(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
- lResult = l1 << shift;
- goto longResultOfArithmetic;
+ wResult = w1 << shift;
+ goto wideResultOfArithmetic;
}
}
@@ -6379,23 +5990,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;
}
}
@@ -6478,18 +6080,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 = w1 + w2;
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Check for overflow.
*/
@@ -6497,14 +6094,10 @@ TEBCresume(
if (Overflowing(w1, w2, wResult)) {
goto overflow;
}
-#endif
goto wideResultOfArithmetic;
case INST_SUB:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = w1 - 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
@@ -6518,7 +6111,6 @@ TEBCresume(
if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
-#endif
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
@@ -6526,46 +6118,46 @@ TEBCresume(
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;
}
}
@@ -6587,6 +6179,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);
@@ -6632,14 +6227,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);
}
@@ -6670,15 +6265,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);
}
@@ -6787,7 +6382,7 @@ TEBCresume(
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
- if (valuePtr->typePtr == &tclBooleanType) {
+ if (TclHasIntRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
@@ -6824,7 +6419,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;
@@ -6835,16 +6431,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));
@@ -6869,7 +6465,7 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
@@ -6878,8 +6474,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
@@ -6899,7 +6495,7 @@ TEBCresume(
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
- if (listLen > iterNum * numVars) {
+ if ((size_t)listLen > iterNum * numVars) {
continueLoop = 1;
}
listTmpIndex++;
@@ -6965,7 +6561,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")));
/*
@@ -6986,8 +6582,9 @@ TEBCresume(
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements, *tmpPtr;
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;
@@ -6998,7 +6595,7 @@ TEBCresume(
*/
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
TRACE(("%u => ", opnd));
@@ -7038,8 +6635,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 */
/*
@@ -7066,13 +6663,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
@@ -7084,7 +6681,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;
@@ -7150,7 +6747,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);
@@ -7167,7 +6764,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));
@@ -7267,56 +6864,25 @@ TEBCresume(
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
+ break;
- case INST_DICT_GET:
case INST_DICT_EXISTS: {
- register Tcl_Interp *interp2 = interp;
- register int found;
+ 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;
}
@@ -7332,6 +6898,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:
@@ -7583,7 +7211,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) {
@@ -7598,13 +7226,16 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewObj(statePtr);
- statePtr->typePtr = &dictIteratorType;
- statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
- statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
+ {
+ Tcl_ObjIntRep ir;
+ TclNewObj(statePtr);
+ ir.twoPtrValue.ptr1 = searchPtr;
+ ir.twoPtrValue.ptr2 = dictPtr;
+ Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir);
+ }
varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
- if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
+ if (TclHasIntRep(varPtr->value.objPtr, &dictIteratorType)) {
Tcl_Panic("mis-issued dictFirst!");
}
TclDecrRefCount(varPtr->value.objPtr);
@@ -7617,11 +7248,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_ObjIntRep *irPtr;
+
+ if (statePtr &&
+ (irPtr = TclFetchIntRep(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);
@@ -7648,7 +7285,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;
}
@@ -7708,7 +7345,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;
}
@@ -7997,6 +7634,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".
@@ -8179,9 +7823,7 @@ TEBCresume(
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
@@ -8244,13 +7886,13 @@ FinalizeOONext(
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
@@ -8270,13 +7912,13 @@ FinalizeOONextFilter(
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
@@ -8290,47 +7932,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) {
@@ -8444,19 +8049,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) \
@@ -8478,12 +8075,12 @@ ExecuteExtendedBinaryMathOp(
int type1, type2;
ClientData 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);
@@ -8492,13 +8089,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.
*/
@@ -8506,12 +8103,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;
/*
@@ -8521,8 +8125,8 @@ ExecuteExtendedBinaryMathOp(
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))))
+ && ((w1 < 0 && w2 > 0)
+ || (w1 > 0 && w2 < 0))))
&& (wQuotient * w2 != w1)) {
wQuotient -= (Tcl_WideInt) 1;
}
@@ -8538,9 +8142,14 @@ ExecuteExtendedBinaryMathOp(
* 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);
}
@@ -8551,24 +8160,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:
@@ -8578,17 +8192,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:
@@ -8605,7 +8214,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];
}
@@ -8618,8 +8227,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
@@ -8631,15 +8240,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_WideInt)1)
<< (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
@@ -8651,8 +8260,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
@@ -8662,17 +8271,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type1) {
- case TCL_NUMBER_LONG:
- zero = (*(const long *)ptr1 > 0L);
+ case TCL_NUMBER_INT:
+ zero = (*(const Tcl_WideInt *)ptr1 > 0);
break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)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:
@@ -8682,35 +8286,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);
@@ -8719,24 +8326,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);
@@ -8744,46 +8356,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;
@@ -8799,96 +8389,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:
+ } 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) {
@@ -8899,119 +8450,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 int type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_LONG type must hold a value larger than we
+ * 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;
+ /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */
+ assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT);
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- LONG_RESULT(signum * (1L << l2));
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2));
- }
-#endif
- goto overflowExpon;
- }
-#if (LONG_MAX == 0x7FFFFFFF)
- if (l2 - 2 < (long)MaxBase32Size
- && l1 <= MaxBase32[l2 - 2]
- && l1 >= -MaxBase32[l2 - 2]) {
- /*
- * Small powers of 32-bit integers.
- */
- lResult = LongPwrSmallExpon(l1, l2);
+ if (w1 == 2) {
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
- LONG_RESULT(lResult);
+ if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2);
}
+ goto overflowExpon;
+ }
+ if (w1 == -2) {
+ int signum = oddExponent ? -1 : 1;
- if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- base = Exp32Index[l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- LONG_RESULT(Exp32Value[base]);
- }
- }
- if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- base = Exp32Index[-l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[-l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
- lResult = (oddExponent) ?
- -Exp32Value[base] : Exp32Value[base];
- LONG_RESULT(lResult);
- }
+ if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2));
}
-#endif
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
- /* Code below (up to overflowExpon) works with wide-int base */
- w1 = l1;
-#endif
+ goto overflowExpon;
}
-
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
-
- /* From here (up to overflowExpon) base is wide-int (w1). */
-
- if (l2 - 2 < (long)MaxBase64Size
- && w1 <= MaxBase64[l2 - 2]
- && w1 >= -MaxBase64[l2 - 2]) {
+ if (w2 - 2 < (long)MaxBase64Size
+ && w1 <= MaxBase64[w2 - 2]
+ && w1 >= -MaxBase64[w2 - 2]) {
/*
* Small powers of integers whose result is wide.
*/
- wResult = WidePwrSmallExpon(w1, l2);
+ wResult = WidePwrSmallExpon(w1, (long)w2);
WIDE_RESULT(wResult);
}
@@ -9022,9 +8531,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
@@ -9036,9 +8545,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
@@ -9049,7 +8558,6 @@ ExecuteExtendedBinaryMathOp(
WIDE_RESULT(wResult);
}
}
-#endif
overflowExpon:
@@ -9061,8 +8569,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);
}
@@ -9122,16 +8635,14 @@ ExecuteExtendedBinaryMathOp(
#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 = w1 + 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.
@@ -9145,9 +8656,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = w1 - 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
@@ -9167,8 +8676,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;
@@ -9180,10 +8688,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;
@@ -9214,38 +8722,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);
@@ -9266,53 +8780,53 @@ ExecuteExtendedUnaryMathOp(
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
@@ -9344,31 +8858,22 @@ TclCompareTwoNumbers(
ClientData 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
@@ -9376,7 +8881,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;
}
@@ -9393,49 +8898,10 @@ TclCompareTwoNumbers(
* integer comparison can tell the difference.
*/
- if (d2 < (double)LONG_MIN) {
- return MP_GT;
- }
- if (d2 > (double)LONG_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) {
+ if (d2 < (double)WIDE_MIN) {
return MP_GT;
}
- if (d2 > (double)LLONG_MAX) {
+ if (d2 > (double)WIDE_MAX) {
return MP_LT;
}
w2 = (Tcl_WideInt) d2;
@@ -9451,7 +8917,6 @@ TclCompareTwoNumbers(
return compare;
}
break;
-#endif
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
@@ -9460,44 +8925,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) {
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;
goto wideCompare;
-#endif
case TCL_NUMBER_BIG:
if (TclIsInfinite(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 {
@@ -9520,10 +8968,7 @@ 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;
@@ -9534,7 +8979,7 @@ TclCompareTwoNumbers(
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;
@@ -9583,14 +9028,14 @@ TclCompareTwoNumbers(
static void
PrintByteCodeInfo(
- register ByteCode *codePtr) /* The bytecode whose summary is printed to
+ ByteCode *codePtr) /* The bytecode whose summary is printed to
* stdout. */
{
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: ");
@@ -9647,7 +9092,7 @@ PrintByteCodeInfo(
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(
- register ByteCode *codePtr, /* The bytecode whose summary is printed to
+ ByteCode *codePtr, /* The bytecode whose summary is printed to
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
@@ -9659,19 +9104,19 @@ ValidatePcAndStackTop(
{
int stackUpperBound = codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
- unsigned relativePc = (unsigned) (pc - codePtr->codeStart);
- unsigned long codeStart = (unsigned long) codePtr->codeStart;
- unsigned long codeEnd = (unsigned long)
+ 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 (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) {
+ if (((size_t) pc < codeStart) || ((size_t) 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 %u in TclNRExecuteByteCode\n",
+ fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
(unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
@@ -9680,7 +9125,7 @@ ValidatePcAndStackTop(
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
- fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
+ fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
@@ -9688,7 +9133,7 @@ ValidatePcAndStackTop(
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");
@@ -9738,7 +9183,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";
@@ -9844,7 +9289,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) {
@@ -9890,7 +9335,7 @@ GetSrcInfoForPc(
* of the command containing the pc should
* be stored. */
{
- register int pcOffset = (pc - codePtr->codeStart);
+ int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
@@ -10043,9 +9488,9 @@ GetExceptRangeForPc(
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
- register ExceptionRange *rangePtr;
+ ExceptionRange *rangePtr;
int pcOffset = pc - codePtr->codeStart;
- register int start;
+ int start;
if (numRanges == 0) {
return NULL;
@@ -10151,7 +9596,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);
}
}
@@ -10177,11 +9622,11 @@ TclExprFloatError(
int
TclLog2(
- register int value) /* The integer for which to compute the log
+ int value) /* The integer for which to compute the log
* base 2. */
{
- register int n = value;
- register int result = 0;
+ int n = value;
+ int result = 0;
while (n > 1) {
n = n >> 1;
@@ -10222,10 +9667,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;
@@ -10267,12 +9712,12 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
- "Compilation and execution statistics for interpreter %#lx\n",
- (long int)iPtr);
+ "Compilation and execution statistics for interpreter %#" TCL_Z_MODIFIER "x\n",
+ (size_t)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);
@@ -10284,7 +9729,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);
@@ -10294,18 +9739,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);
@@ -10336,17 +9781,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);
/*
@@ -10364,10 +9809,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 (TclHasIntRep(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));
@@ -10383,20 +9828,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);
@@ -10421,7 +9866,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",
@@ -10471,7 +9916,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;
@@ -10569,7 +10015,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",
@@ -10589,7 +10035,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 99372c5..3babd43 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -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. */
@@ -1085,12 +1085,9 @@ TclFileAttrsCmd(
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", 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", 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,151 @@ 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;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 8fb9f4d..5705a11 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -387,7 +387,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] == '~') {
/*
@@ -578,7 +578,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 +587,7 @@ Tcl_SplitPath(
* plus the argv pointers and the terminating NULL pointer.
*/
- *argvPtr = ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size);
+ *argvPtr = (const char **)ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size);
/*
* Position p after the last argv pointer and copy the contents of the
@@ -597,8 +597,8 @@ Tcl_SplitPath(
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- str = Tcl_GetStringFromObj(eltPtr, &len);
- memcpy(p, str, (size_t) len+1);
+ str = TclGetStringFromObj(eltPtr, &len);
+ memcpy(p, str, len+1);
p += len+1;
}
@@ -821,7 +821,7 @@ Tcl_FSJoinToPath(
return TclJoinPath(2, pair, 0);
} else {
int elemc = objc + 1;
- Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj *));
+ Tcl_Obj *ret, **elemv = (Tcl_Obj**)ckalloc(elemc*sizeof(Tcl_Obj *));
elemv[0] = pathPtr;
memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
@@ -857,7 +857,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
@@ -885,7 +885,7 @@ TclpNativeJoinPath(
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
- Tcl_GetStringFromObj(prefix, &length);
+ TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -921,7 +921,7 @@ TclpNativeJoinPath(
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
- Tcl_GetStringFromObj(prefix, &length);
+ TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -1003,7 +1003,7 @@ Tcl_JoinPath(
* Store the result.
*/
- resultStr = Tcl_GetStringFromObj(resultObj, &len);
+ resultStr = TclGetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
@@ -1072,7 +1072,7 @@ Tcl_TranslateFileName(
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
- register char *p;
+ char *p;
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '/') {
*p = '\\';
@@ -1217,10 +1217,9 @@ DoTildeSubst(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
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. */
@@ -1249,7 +1248,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
@@ -1344,7 +1343,7 @@ Tcl_GlobObjCmd(
return TCL_ERROR;
}
- separators = NULL; /* lint. */
+ separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
@@ -1357,7 +1356,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
@@ -1449,7 +1448,7 @@ Tcl_GlobObjCmd(
if (length <= 0) {
goto skipTypes;
}
- globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
+ globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
@@ -1460,7 +1459,7 @@ Tcl_GlobObjCmd(
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
- str = Tcl_GetStringFromObj(look, &len);
+ str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
@@ -1680,9 +1679,8 @@ Tcl_GlobObjCmd(
*
* TclGlob --
*
- * This procedure prepares arguments for the DoGlob call. It sets the
- * separator string based on the platform, performs * tilde substitution,
- * and calls DoGlob.
+ * Sets the separator string based on the platform, performs tilde
+ * substitution, and calls DoGlob.
*
* The interpreter's result, on entry to this function, must be a valid
* Tcl list (e.g. it could be empty), since we will lappend any new
@@ -1705,7 +1703,6 @@ Tcl_GlobObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
TclGlob(
Tcl_Interp *interp, /* Interpreter for returning error message or
@@ -1724,7 +1721,7 @@ TclGlob(
int result;
Tcl_Obj *filenamesObj, *savedResultObj;
- separators = NULL; /* lint. */
+ separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
@@ -1881,7 +1878,7 @@ TclGlob(
separators = "/\\";
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
- if (pathPrefix == NULL && tail[0] == '/') {
+ if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') {
pathPrefix = Tcl_NewStringObj(tail, 1);
tail++;
Tcl_IncrRefCount(pathPrefix);
@@ -1992,7 +1989,7 @@ TclGlob(
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
- pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
+ pre = TclGetStringFromObj(pathPrefix, &prefixLen);
if (prefixLen > 0
&& (strchr(separators, pre[prefixLen-1]) == NULL)) {
/*
@@ -2010,7 +2007,7 @@ TclGlob(
Tcl_ListObjGetElements(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) {
@@ -2077,7 +2074,7 @@ SkipToChar(
int match) /* Character to find. */
{
int quoted, level;
- register char *p;
+ char *p;
quoted = 0;
level = 0;
@@ -2362,7 +2359,7 @@ DoGlob(
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);
@@ -2400,7 +2397,7 @@ DoGlob(
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
- (void) Tcl_GetStringFromObj(pathPtr, &length);
+ (void) TclGetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
@@ -2446,7 +2443,7 @@ DoGlob(
*/
int len;
- const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
+ const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
Tcl_AppendToObj(joinedPtr, "/", 1);
@@ -2483,7 +2480,7 @@ DoGlob(
*/
int len;
- const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
+ const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
@@ -2523,7 +2520,7 @@ DoGlob(
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
- return ckalloc(sizeof(Tcl_StatBuf));
+ return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf));
}
/*
@@ -2548,21 +2545,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
@@ -2628,26 +2625,31 @@ Tcl_GetBlocksFromStat(
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
return (Tcl_WideUInt) statPtr->st_blocks;
#else
- register unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
+ unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
return ((Tcl_WideUInt) 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/tclGet.c b/generic/tclGet.c
index 97e8c7b..12e0e79 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -142,7 +142,7 @@ Tcl_GetBoolean(
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
- *boolPtr = obj.internalRep.longValue;
+ TclGetBooleanFromObj(NULL, &obj, boolPtr);
}
return code;
}
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index d38235a..f8fded2 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -960,7 +960,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- void *dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
@@ -970,7 +970,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 193664d..584b5e1 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -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:
@@ -126,7 +113,7 @@ const Tcl_HashKeyType tclStringHashKeyType = {
void
Tcl_InitHashTable(
- register Tcl_HashTable *tablePtr,
+ Tcl_HashTable *tablePtr,
/* Pointer to table record, which is supplied
* by the caller. */
int keyType) /* Type of keys to use in table:
@@ -164,7 +151,7 @@ Tcl_InitHashTable(
void
Tcl_InitCustomHashTable(
- register Tcl_HashTable *tablePtr,
+ Tcl_HashTable *tablePtr,
/* Pointer to table record, which is supplied
* by the caller. */
int keyType, /* Type of keys to use in table:
@@ -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 *
@@ -284,7 +271,7 @@ CreateHashEntry(
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
unsigned int hash;
int index;
@@ -321,11 +308,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 +324,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 +348,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;
}
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++;
/*
@@ -415,13 +392,11 @@ void
Tcl_DeleteHashEntry(
Tcl_HashEntry *entryPtr)
{
- register Tcl_HashEntry *prevPtr;
+ Tcl_HashEntry *prevPtr;
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
-#if TCL_HASH_KEY_STORE_HASH
int index;
-#endif
tablePtr = entryPtr->tablePtr;
@@ -436,7 +411,6 @@ 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));
@@ -445,9 +419,6 @@ Tcl_DeleteHashEntry(
}
bucketPtr = &tablePtr->buckets[index];
-#else
- bucketPtr = entryPtr->bucketPtr;
-#endif
if (*bucketPtr == entryPtr) {
*bucketPtr = entryPtr->nextPtr;
@@ -490,9 +461,9 @@ Tcl_DeleteHashEntry(
void
Tcl_DeleteHashTable(
- register Tcl_HashTable *tablePtr) /* Table to delete. */
+ Tcl_HashTable *tablePtr) /* Table to delete. */
{
- register Tcl_HashEntry *hPtr, *nextPtr;
+ Tcl_HashEntry *hPtr, *nextPtr;
const Tcl_HashKeyType *typePtr;
int i;
@@ -598,7 +569,7 @@ Tcl_FirstHashEntry(
Tcl_HashEntry *
Tcl_NextHashEntry(
- register Tcl_HashSearch *searchPtr)
+ Tcl_HashSearch *searchPtr)
/* Place to store information about progress
* through the table. Must have been
* initialized by calling
@@ -645,7 +616,7 @@ Tcl_HashStats(
#define NUM_COUNTERS 10
int count[NUM_COUNTERS], overflow, i, j;
double average, tmp;
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *hPtr;
char *result, *p;
/*
@@ -677,7 +648,7 @@ Tcl_HashStats(
* Print out the histogram and a few other pieces of information.
*/
- result = ckalloc((NUM_COUNTERS * 60) + 300);
+ result = (char *)ckalloc((NUM_COUNTERS * 60) + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
@@ -715,7 +686,7 @@ AllocArrayEntry(
void *keyPtr) /* Key to store in the hash table entry. */
{
int *array = (int *) keyPtr;
- register int *iPtr1, *iPtr2;
+ int *iPtr1, *iPtr2;
Tcl_HashEntry *hPtr;
int count;
unsigned int size;
@@ -726,7 +697,7 @@ AllocArrayEntry(
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++) {
@@ -759,8 +730,8 @@ CompareArrayKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- register const int *iPtr1 = (const int *) keyPtr;
- register const int *iPtr2 = (const int *) hPtr->key.words;
+ const int *iPtr1 = (const int *) keyPtr;
+ const int *iPtr2 = (const int *) hPtr->key.words;
Tcl_HashTable *tablePtr = hPtr->tablePtr;
int count;
@@ -793,13 +764,13 @@ CompareArrayKeys(
*----------------------------------------------------------------------
*/
-static unsigned int
+static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
- register const int *array = (const int *) keyPtr;
- register unsigned int result;
+ const int *array = (const int *) keyPtr;
+ TCL_HASH_TYPE result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
@@ -827,18 +798,18 @@ HashArrayKey(
static Tcl_HashEntry *
AllocStringEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ 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);
+ hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize);
memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key));
memcpy(hPtr->key.string, string, size);
hPtr->clientData = 0;
@@ -867,8 +838,8 @@ CompareStringKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- register const char *p1 = (const char *) keyPtr;
- register const char *p2 = (const char *) hPtr->key.string;
+ const char *p1 = (const char *) keyPtr;
+ const char *p2 = (const char *) hPtr->key.string;
return !strcmp(p1, p2);
}
@@ -890,14 +861,14 @@ CompareStringKeys(
*----------------------------------------------------------------------
*/
-static unsigned
+static TCL_HASH_TYPE
HashStringKey(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
- register const char *string = keyPtr;
- register unsigned int result;
- register char c;
+ const char *string = (const char *)keyPtr;
+ TCL_HASH_TYPE result;
+ char c;
/*
* I tried a zillion different hash functions and asked many other people
@@ -944,7 +915,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 +927,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 +941,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 +953,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;
@@ -1016,12 +983,12 @@ BogusCreate(
static void
RebuildTable(
- register Tcl_HashTable *tablePtr) /* Table to enlarge. */
+ Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
int count, index, oldSize = tablePtr->numBuckets;
Tcl_HashEntry **oldBuckets = tablePtr->buckets;
- register Tcl_HashEntry **oldChainPtr, **newChainPtr;
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry **oldChainPtr, **newChainPtr;
+ Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
/* Avoid outgrowing capability of the memory allocators */
@@ -1048,11 +1015,11 @@ 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++) {
@@ -1069,7 +1036,6 @@ 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));
@@ -1078,26 +1044,6 @@ RebuildTable(
}
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 b08e352..3a52a20 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -61,16 +61,15 @@ Tcl_RecordAndEval(
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
* instead of Tcl_Eval. */
{
- register Tcl_Obj *cmdPtr;
- int length = strlen(cmd);
+ Tcl_Obj *cmdPtr;
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);
@@ -131,14 +130,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);
@@ -212,9 +211,9 @@ Tcl_RecordAndEvalObj(
static void
DeleteHistoryObjs(
ClientData clientData,
- Tcl_Interp *interp)
+ TCL_UNUSED(Tcl_Interp *))
{
- register HistoryObjs *histObjsPtr = clientData;
+ HistoryObjs *histObjsPtr = (HistoryObjs *)clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index ab8d8ac..0e80fd5 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -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. */
@@ -201,7 +201,7 @@ 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,
@@ -319,9 +319,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 DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -335,6 +335,22 @@ static const Tcl_ObjType chanObjType = {
NULL /* setFromAnyProc */
};
+#define ChanSetIntRep(objPtr, resPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (resPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (resPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \
+ } while (0)
+
+#define ChanGetIntRep(objPtr, resPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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 +374,12 @@ ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
- if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
+#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);
}
/*
@@ -465,18 +482,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 -1;
+ }
- 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 -1;
+#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 +579,6 @@ TclInitIOSubsystem(void)
*-------------------------------------------------------------------------
*/
- /* ARGSUSED */
void
TclFinalizeIOSubsystem(void)
{
@@ -1493,23 +1514,22 @@ TclGetChannelFromObj(
* channel was opened? Will contain an ORed
* 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) {
+ ChanGetIntRep(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,22 +1546,21 @@ TclGetChannelFromObj(
if (chan == NULL) {
if (resPtr) {
- FreeChannelIntRep(objPtr);
+ Tcl_StoreIntRep(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((ClientData) 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;
+ ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
@@ -1602,9 +1621,18 @@ Tcl_CreateChannel(
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
- if (NULL == typePtr->closeProc) {
- Tcl_Panic("channel type %s must define closeProc", typePtr->typeName);
+#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 +1642,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
@@ -3353,7 +3383,6 @@ Tcl_SpliceChannel(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_Close(
Tcl_Interp *interp, /* Interpreter for errors. */
@@ -3443,6 +3472,11 @@ Tcl_Close(
Tcl_ClearChannelHandlers(chan);
/*
+ * Cancel any outstanding timer.
+ */
+ Tcl_DeleteTimerHandler(statePtr->timer);
+
+ /*
* Invoke the registered close callbacks and delete their records.
*/
@@ -3460,13 +3494,20 @@ Tcl_Close(
* it anymore and this will help avoid deadlocks on some channel types.
*/
- if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
- result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp,
- TCL_CLOSE_READ);
+#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);
if ((result == EINVAL) || result == ENOTCONN) {
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
@@ -3530,24 +3571,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. */
@@ -4203,8 +4241,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);
@@ -4225,9 +4266,11 @@ WillRead(
Tcl_SetErrno(EINVAL);
return -1;
}
- if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
- && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
-
+ if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
+#ifndef TCL_NO_DEPRECATED
+ || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
+#endif
+ ) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
/*
* CAVEAT - The assumption here is that FlushChannel() will push out
* the bytes of any writes that are in progress. Since this is a
@@ -4314,7 +4357,7 @@ Write(
* that we need to stick at the beginning of this buffer.
*/
- memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
+ memcpy(InsertPoint(bufPtr), safe, saved);
bufPtr->nextAdded += saved;
saved = 0;
}
@@ -4441,6 +4484,8 @@ Write(
}
}
+ UpdateInterest(chanPtr);
+
return total;
}
@@ -5185,10 +5230,9 @@ TclGetsObjBinary(
static void
FreeBinaryEncoding(
- ClientData dummy) /* Not used */
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)dummy;
if (tsdPtr->binaryEncoding != NULL) {
Tcl_FreeEncoding(tsdPtr->binaryEncoding);
@@ -5197,7 +5241,7 @@ FreeBinaryEncoding(
}
static Tcl_Encoding
-GetBinaryEncoding()
+GetBinaryEncoding(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -5818,7 +5862,11 @@ DoReadChars(
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
- if (appendFlag == 0) {
+ if (appendFlag) {
+ if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) {
+ binaryMode = 0;
+ }
+ } else {
if (binaryMode) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
@@ -6828,24 +6876,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
@@ -6988,7 +7033,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;
}
@@ -7152,7 +7201,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;
}
@@ -7186,47 +7239,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.
@@ -8557,6 +8569,16 @@ UpdateInterest(
}
}
}
+
+ if (!statePtr->timer
+ && mask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ }
+
+
ChanWatch(chanPtr, mask);
}
@@ -8585,6 +8607,21 @@ ChannelTimerProc(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
+ 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_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
+ }
+
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
@@ -8596,13 +8633,11 @@ ChannelTimerProc(
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
- Tcl_Preserve(statePtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
- Tcl_Release(statePtr);
} else {
- statePtr->timer = NULL;
UpdateInterest(chanPtr);
}
+ Tcl_Release(statePtr);
}
/*
@@ -8915,20 +8950,19 @@ CreateScriptRecord(
void
TclChannelEventScriptInvoker(
ClientData clientData, /* The script+interp record. */
- int mask) /* Not used. */
+ 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]).
*/
@@ -8981,10 +9015,9 @@ TclChannelEventScriptInvoker(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FileEventObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which the channel for which
* to create the handler is found. */
int objc, /* Number of arguments. */
@@ -8998,7 +9031,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?");
@@ -9108,6 +9140,7 @@ ZeroTransferTimerProc(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
@@ -9119,6 +9152,7 @@ TclCopyChannelOld(
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
int
TclCopyChannel(
@@ -10527,6 +10561,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)) {
/*
@@ -10535,6 +10570,7 @@ Tcl_ChannelVersion(
*/
return TCL_CHANNEL_VERSION_1;
}
+#endif
return chanTypePtr->version;
}
@@ -10558,13 +10594,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;
}
@@ -10584,6 +10621,7 @@ Tcl_ChannelBlockModeProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10591,6 +10629,7 @@ Tcl_ChannelCloseProc(
{
return chanTypePtr->closeProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10680,6 +10719,7 @@ Tcl_ChannelOutputProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10687,6 +10727,7 @@ Tcl_ChannelSeekProc(
{
return chanTypePtr->seekProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10805,9 +10846,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;
}
@@ -10832,9 +10875,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;
}
@@ -10859,9 +10904,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;
}
@@ -10887,9 +10934,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;
}
@@ -11233,11 +11282,11 @@ DupChannelIntRep(
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;
+ ChanGetIntRep(srcPtr, resPtr);
+ assert(resPtr);
+ ChanSetIntRep(copyPtr, resPtr);
}
/*
@@ -11260,10 +11309,11 @@ static void
FreeChannelIntRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- objPtr->typePtr = NULL;
- if (--resPtr->refCount) {
+ ChanGetIntRep(objPtr, resPtr);
+ assert(resPtr);
+ if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
diff --git a/generic/tclIO.h b/generic/tclIO.h
index ffbfa31..d10f268 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -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
@@ -214,7 +214,7 @@ 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. */
} ChannelState;
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index af1295f..508a991 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -16,7 +16,7 @@
*/
typedef struct AcceptCallback {
- char *script; /* Script to invoke. */
+ 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,19 +36,14 @@ 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 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(ClientData callbackData);
static void UnregisterTcpServerInterpCleanupProc(
Tcl_Interp *interp,
@@ -72,7 +67,7 @@ static void UnregisterTcpServerInterpCleanupProc(
static void
FinalizeIOCmdTSD(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -100,10 +95,9 @@ FinalizeIOCmdTSD(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_PutsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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(ClientData),
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(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -378,10 +369,9 @@ Tcl_GetsObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ReadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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(ClientData),
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(ClientData),
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(ClientData),
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(ClientData),
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(ClientData),
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(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -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(
resultPtr = Tcl_NewObj();
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(ClientData),
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(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1225,20 +1207,19 @@ Tcl_OpenObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(
ClientData 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 +1261,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 +1307,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;
}
@@ -1364,7 +1345,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 +1354,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_NewIntObj(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 +1379,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 +1395,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
@@ -1443,14 +1431,14 @@ TcpServerCloseProc(
ClientData 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,19 +1461,24 @@ TcpServerCloseProc(
int
Tcl_SocketObjCmd(
- ClientData notUsed, /* 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 socketOptions[] = {
- "-async", "-myaddr", "-myport", "-server", NULL
+ "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
+ NULL
};
enum socketOptions {
- SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
+ SKT_ASYNC, 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;
+ unsigned int flags = 0;
+ const char *host, *port, *myaddr = NULL;
+ Tcl_Obj *script = NULL;
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
@@ -1548,7 +1541,29 @@ 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;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
@@ -1573,32 +1588,63 @@ Tcl_SocketObjCmd(
"?-myaddr addr? ?-myport myport? ?-async? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
- "-server command ?-myaddr addr? port");
+ "-server command ?-reuseaddr boolean? ?-reuseport boolean? "
+ "?-myaddr addr? 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)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "options -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,
+ AcceptCallbackProc, acceptCallbackPtr);
if (chan == NULL) {
- ckfree(copyScript);
+ Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
return TCL_ERROR;
}
@@ -1620,7 +1666,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 +1703,7 @@ Tcl_SocketObjCmd(
int
Tcl_FcopyObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1744,10 +1796,9 @@ Tcl_FcopyObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ChanPendingObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1809,7 +1860,7 @@ ChanPendingObjCmd(
static int
ChanTruncateObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1844,7 +1895,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 +1933,7 @@ ChanTruncateObjCmd(
static int
ChanPipeObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1933,7 +1984,7 @@ ChanPipeObjCmd(
int
TclChannelNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index dadcb53..353998f 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -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);
@@ -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. */
@@ -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
/*
*----------------------------------------------------------------------
@@ -919,7 +917,9 @@ TransformWideSeekProc(
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);
@@ -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 9969b87..8a5675a 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -32,8 +32,6 @@
*/
static int ReflectClose(ClientData clientData,
- Tcl_Interp *interp);
-static int ReflectClose2(ClientData clientData,
Tcl_Interp *interp, int flags);
static int ReflectInput(ClientData clientData, char *buf,
int toRead, int *errorCodePtr);
@@ -41,21 +39,25 @@ static int ReflectOutput(ClientData 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
+#if TCL_THREADS
static void ReflectThread(ClientData clientData, int action);
static int ReflectEventRun(Tcl_Event *ev, int flags);
static int ReflectEventDelete(Tcl_Event *ev, ClientData cd);
#endif
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
static int ReflectSeek(ClientData clientData, long offset,
int mode, int *errorCodePtr);
+#endif
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
+static void TimerRunRead(ClientData clientData);
+static void TimerRunWrite(ClientData clientData);
/*
* The C layer channel type/driver definition used by the reflection. This is
@@ -65,23 +67,27 @@ 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 */
};
@@ -99,7 +105,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
@@ -114,6 +120,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.
*
@@ -123,11 +140,9 @@ typedef struct {
*
* See 'rechan', '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;
@@ -203,7 +218,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.
*
@@ -238,7 +253,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
@@ -313,7 +328,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 */
@@ -350,7 +365,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.
@@ -410,7 +425,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 */
@@ -437,8 +452,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);
@@ -453,7 +467,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}";
@@ -483,7 +497,7 @@ static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo
int
TclChanCreateObjCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -509,7 +523,6 @@ TclChanCreateObjCmd(
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
- (void)dummy;
/*
* Syntax: chan create MODE CMDPREFIX
@@ -596,7 +609,7 @@ TclChanCreateObjCmd(
if (Tcl_ListObjGetElements(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;
}
@@ -622,35 +635,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;
}
@@ -688,7 +701,9 @@ TclChanCreateObjCmd(
clonePtr->blockModeProc = NULL;
}
if (!(methods & FLAG(METH_SEEK))) {
+#ifndef TCL_NO_DEPRECATED
clonePtr->seekProc = NULL;
+#endif
clonePtr->wideSeekProc = NULL;
}
@@ -709,7 +724,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);
@@ -728,7 +743,7 @@ TclChanCreateObjCmd(
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
- ckfree((char*) rcPtr);
+ ckfree(rcPtr);
return TCL_ERROR;
#undef MODE
@@ -753,8 +768,8 @@ TclChanCreateObjCmd(
*----------------------------------------------------------------------
*/
-#ifdef TCL_THREADS
-typedef struct ReflectEvent {
+#if TCL_THREADS
+typedef struct {
Tcl_Event header;
ReflectedChannel *rcPtr;
int events;
@@ -763,7 +778,7 @@ typedef struct ReflectEvent {
static int
ReflectEventRun(
Tcl_Event *ev,
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
/* OWNER thread
*
@@ -773,7 +788,6 @@ ReflectEventRun(
*/
ReflectEvent *e = (ReflectEvent *) ev;
- (void)flags;
Tcl_NotifyChannel(e->rcPtr->chan, e->events);
return 1;
@@ -802,7 +816,7 @@ ReflectEventDelete(
int
TclChanPostEventObjCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -831,7 +845,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...
@@ -922,11 +935,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));
@@ -973,6 +997,24 @@ TclChanPostEventObjCmd(
#undef EVENT
}
+static void
+TimerRunRead(
+ ClientData clientData)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ rcPtr->readTimer = NULL;
+ Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
+}
+
+static void
+TimerRunWrite(
+ ClientData clientData)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ rcPtr->writeTimer = NULL;
+ Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
+}
+
/*
* Channel error message marshalling utilities.
*/
@@ -1098,7 +1140,7 @@ TclChanCaughtErrorBypass(
/*
*----------------------------------------------------------------------
*
- * ReflectClose/ReflectClose2 --
+ * ReflectClose --
*
* This function is invoked when the channel is closed, to delete the
* driver specific instance data.
@@ -1115,7 +1157,8 @@ TclChanCaughtErrorBypass(
static int
ReflectClose(
ClientData clientData,
- Tcl_Interp *interp)
+ Tcl_Interp *interp,
+ int flags)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
int result; /* Result code for 'close' */
@@ -1125,6 +1168,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
@@ -1142,7 +1189,7 @@ ReflectClose(
* if lost?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1163,9 +1210,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;
}
@@ -1174,7 +1227,7 @@ ReflectClose(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1221,7 +1274,7 @@ ReflectClose(
Tcl_DeleteHashEntry(hPtr);
}
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
@@ -1232,24 +1285,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;
-}
/*
*----------------------------------------------------------------------
@@ -1284,7 +1331,7 @@ ReflectInput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1390,7 +1437,7 @@ ReflectOutput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1519,7 +1566,7 @@ ReflectSeekWide(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1579,6 +1626,7 @@ ReflectSeekWide(
goto stop;
}
+#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
ClientData clientData,
@@ -1593,9 +1641,10 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1642,7 +1691,7 @@ ReflectWatch(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1700,7 +1749,7 @@ ReflectBlock(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1736,7 +1785,7 @@ ReflectBlock(
return errorNum;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1806,7 +1855,7 @@ ReflectSetOption(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1885,9 +1934,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;
@@ -1975,7 +2024,7 @@ ReflectGetOption(
goto error;
} else {
int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
@@ -2139,7 +2188,7 @@ NewReflectedChannel(
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
- MethodName mn = METH_BLOCKING;
+ int mn = 0;
rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));
@@ -2148,7 +2197,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;
@@ -2158,7 +2209,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));
}
@@ -2348,7 +2399,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);
@@ -2427,7 +2478,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;
@@ -2464,8 +2515,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;
}
@@ -2523,7 +2573,7 @@ DeleteReflectedChannelMap(
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
-#ifdef TCL_THREADS
+#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
@@ -2553,7 +2603,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.
*/
@@ -2639,7 +2689,7 @@ DeleteReflectedChannelMap(
#endif
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2691,14 +2741,13 @@ GetThreadReflectedChannelMap(void)
static void
DeleteThreadReflectedChannelMap(
- ClientData dummy) /* The per-thread data structure. */
+ TCL_UNUSED(ClientData))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedChannelMap *rcmPtr; /* The map */
ForwardingResult *resultPtr;
- (void)dummy;
/*
* The origin thread for one or more reflected channels is gone.
@@ -2916,7 +2965,7 @@ ForwardOpToHandlerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /* mask */)
{
/*
* HANDLER thread.
@@ -2945,7 +2994,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.
@@ -3214,7 +3262,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, " ");
@@ -3313,7 +3361,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 039b594..9a82cdb 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -32,8 +32,6 @@
*/
static int ReflectClose(ClientData clientData,
- Tcl_Interp *interp);
-static int ReflectClose2(ClientData clientData,
Tcl_Interp *interp, int flags);
static int ReflectInput(ClientData clientData, char *buf,
int toRead, int *errorCodePtr);
@@ -43,8 +41,10 @@ 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);
+#ifndef TCL_NO_DEPRECATED
static int ReflectSeek(ClientData clientData, long offset,
int mode, int *errorCodePtr);
+#endif
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
@@ -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. */
@@ -85,7 +89,7 @@ static const Tcl_ChannelType tclRTransformType = {
* layers upon reading from the channel, plus the functions to manage such.
*/
-typedef struct _ResultBuffer_ {
+typedef struct {
unsigned char *buf; /* Reference to the buffer area. */
int allocated; /* Allocated size of the buffer area. */
int used; /* Number of bytes in the buffer,
@@ -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.
*/
@@ -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 */
@@ -499,7 +503,7 @@ static int TransformLimit(ReflectedTransform *rtPtr,
int
TclChanPushObjCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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;
}
@@ -607,7 +610,7 @@ TclChanPushObjCmd(
if (Tcl_ListObjGetElements(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(ClientData),
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...
@@ -883,7 +885,8 @@ UnmarshallErrorResult(
static int
ReflectClose(
ClientData clientData,
- Tcl_Interp *interp)
+ 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;
-}
/*
*----------------------------------------------------------------------
@@ -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,6 +1408,7 @@ ReflectSeekWide(
return curPos;
}
+#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
ClientData clientData,
@@ -1433,9 +1423,10 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -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;
@@ -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);
@@ -2164,7 +2154,7 @@ DeleteReflectedTransformMap(
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedTransform *rtPtr;
-#ifdef TCL_THREADS
+#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
@@ -2194,7 +2184,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 +2256,7 @@ DeleteReflectedTransformMap(
#endif /* TCL_THREADS */
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2318,14 +2308,13 @@ GetThreadReflectedTransformMap(void)
static void
DeleteThreadReflectedTransformMap(
- ClientData dummy) /* The per-thread data structure. */
+ TCL_UNUSED(ClientData))
{
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.
@@ -2513,7 +2502,7 @@ ForwardOpToOwnerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /*mask*/)
{
/*
* Notes regarding access to the referenced data.
@@ -2538,7 +2527,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 +2570,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 +2580,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);
@@ -2821,7 +2809,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));
@@ -2969,7 +2957,7 @@ ResultClear(
return;
}
- ckfree((char *) rPtr->buf);
+ ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
@@ -3102,7 +3090,7 @@ TransformRead(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3158,7 +3146,7 @@ TransformWrite(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3224,7 +3212,7 @@ TransformDrain(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3274,7 +3262,7 @@ TransformFlush(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3329,7 +3317,7 @@ TransformClear(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3361,7 +3349,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..adf729a 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -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, TCL_TCPSERVER_REUSEADDR,
+ acceptProc, callbackData);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 7c2c478..db533d7 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1,14 +1,11 @@
/*
* 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.
- *
- * Parts of this file are based on code contributed by Karl Lehenbauer,
- * Mark Diekhans and Peter da Silva.
+ * 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.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
@@ -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 accomodate 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 (un-equal) 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,7 +1062,7 @@ 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 = Tcl_ListObjGetElements(interp, tmpResultPtr,
@@ -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));
@@ -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.
+ * 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 = Tcl_GetStringFromObj(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 system encoding. */
{
int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
@@ -1756,15 +1714,16 @@ 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 don't touch it, leaving things up to the system encoding. If
+ * the encoding is unknown report an error.
*/
if (encodingName != NULL) {
@@ -1779,11 +1738,10 @@ Tcl_FSEvalFileEx(
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 system encoding. */
{
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile, *objPtr;
@@ -1888,17 +1847,19 @@ 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 don't touch it, leaving things up to the system encoding. If
+ * the encoding is unknown report an error.
*/
if (encodingName != NULL) {
@@ -1913,11 +1874,10 @@ TclNREvalFile(
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,10 @@ Tcl_PosixError(
*----------------------------------------------------------------------
*
* Tcl_FSStat --
+ * Calls 'statProc' of the filesystem corresponding to pathPtr.
*
- * This function replaces the library version of stat and lsat.
+ * Replaces the standard library routines stat.
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
*
* Results:
* See stat documentation.
@@ -2121,8 +2076,10 @@ Tcl_PosixError(
int
Tcl_FSStat(
- Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf) /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
+ * current CP). */
+ Tcl_StatBuf *buf) /* A buffer to hold the results of the call to
+ * stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2137,11 +2094,11 @@ Tcl_FSStat(
*----------------------------------------------------------------------
*
* Tcl_FSLstat --
+ * Calls the 'lstatProc' of the filesystem corresponding to pathPtr.
*
- * This function replaces the library version of lstat. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
- * If no 'lstat' function is listed, but a 'stat' function is, then Tcl
- * will fall back on the stat function.
+ * Replaces the library version of lstat. If the filesystem doesn't
+ * provide lstatProc but does provide statProc, Tcl falls back to
+ * statProc.
*
* Results:
* See lstat documentation.
@@ -2154,8 +2111,9 @@ Tcl_FSStat(
int
Tcl_FSLstat(
- Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf) /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
+ current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of that call to stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2176,8 +2134,9 @@ Tcl_FSLstat(
*
* Tcl_FSAccess --
*
- * This function replaces the library version of access. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
+ * Calls 'accessProc' of the filesystem corresponding to pathPtr.
+ *
+ * Replaces the library version of access.
*
* Results:
* See access documentation.
@@ -2190,7 +2149,7 @@ Tcl_FSLstat(
int
Tcl_FSAccess(
- Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */
+ Tcl_Obj *pathPtr, /* Pathname of file to access (in current CP). */
int mode) /* Permission setting. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2207,38 +2166,36 @@ Tcl_FSAccess(
*
* Tcl_FSOpenFileChannel --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'openfileChannelProc' of the filesystem corresponding to
+ * pathPtr.
*
* Results:
- * The new channel or NULL, if the named file could not be opened.
+ * The new channel, or NULL if the named file could not be opened.
*
* Side effects:
- * May open the channel and may cause creation of a file on the file
- * system.
+ * Opens a channel, possibly creating the corresponding the file on the
+ * filesystem.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_FSOpenFileChannel(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- Tcl_Obj *pathPtr, /* Name of file to open. */
+ Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */
+ Tcl_Obj *pathPtr, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
+ int permissions) /* What modes to use if opening the file
+ involves creating it. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
- /*
- * We need this just to ensure we return the correct error messages under
- * some circumstances.
- */
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
+ /*
+ * Return the correct error message.
+ */
return NULL;
}
@@ -2247,8 +2204,8 @@ Tcl_FSOpenFileChannel(
int mode, seekFlag, binary;
/*
- * Parse the mode, picking up whether we want to seek to start with
- * and/or set the channel automatically into binary mode.
+ * Parse the mode to determine whether to seek at the outset
+ * and/or set the channel into binary mode.
*/
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
@@ -2257,7 +2214,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Do the actual open() call.
+ * Open the file.
*/
retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
@@ -2267,7 +2224,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Apply appropriate flags parsed out above.
+ * Seek and/or set binary mode as determined above.
*/
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
@@ -2304,8 +2261,10 @@ Tcl_FSOpenFileChannel(
*
* Tcl_FSUtime --
*
- * This function replaces the library version of utime. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
+ * Calls 'uTimeProc' of the filesystem corresponding to the given
+ * pathname.
+ *
+ * Replaces the library version of utime.
*
* Results:
* See utime documentation.
@@ -2318,9 +2277,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 +2295,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 +2311,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 +2322,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 +2345,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 +2356,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 +2374,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 +2385,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 +2421,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 +2437,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;
@@ -2541,15 +2499,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 +2519,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 +2537,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 +2555,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 +2573,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 +2610,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 +2622,7 @@ Tcl_FSGetCwd(
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
+
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
@@ -2683,7 +2638,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 +2646,15 @@ 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,29 +2674,27 @@ 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);
@@ -2750,13 +2703,19 @@ Tcl_FSGetCwd(
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,38 +3004,27 @@ 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. */
+ /* Names of two functions to find in the
+ * dynamic shared object. */
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
+ /* 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];
@@ -3113,101 +3041,103 @@ 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.
*/
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
- char* skipstr;
+ char *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 */
}
@@ -3215,16 +3145,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);
@@ -3262,10 +3191,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) {
@@ -3279,9 +3209,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:
*/
{
@@ -3297,7 +3227,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) {
@@ -3312,7 +3242,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);
@@ -3328,8 +3258,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);
@@ -3341,11 +3270,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) {
@@ -3356,10 +3289,6 @@ Tcl_LoadFile(
}
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
- /*
- * Cross-platform copy failed.
- */
-
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
@@ -3367,10 +3296,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:
*/
{
@@ -3387,8 +3315,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) {
@@ -3398,30 +3326,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;
@@ -3432,47 +3354,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;
@@ -3482,7 +3398,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;
@@ -3495,8 +3411,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) {
@@ -3505,9 +3421,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);
@@ -3524,16 +3439,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;
@@ -3546,83 +3462,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.
+ * 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 cause the filesystem to be
+ * deallocated if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
@@ -3637,23 +3545,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);
}
@@ -3663,16 +3571,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) {
@@ -3693,52 +3600,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.
*/
@@ -3746,33 +3646,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.
- *
- * 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 case filesystem to be freed
+ * if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
@@ -3786,38 +3685,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);
@@ -3827,11 +3729,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
@@ -3847,16 +3748,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.
@@ -3874,10 +3768,9 @@ Tcl_FSListVolumes(void)
Tcl_Obj *resultPtr = Tcl_NewObj();
/*
- * 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.
*/
fsRecPtr = FsGetFirstFilesystem();
@@ -3888,6 +3781,10 @@ 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);
}
}
@@ -3903,22 +3800,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;
@@ -3926,10 +3822,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();
@@ -3955,34 +3849,31 @@ 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.
*
*---------------------------------------------------------------------------
*/
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,
@@ -3994,9 +3885,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);
@@ -4009,9 +3898,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.
*/
result = Tcl_NewObj();
@@ -4021,7 +3910,7 @@ Tcl_FSSplitPath(
p += driveNameLength;
/*
- * Add the remaining path elements to the list.
+ * Add the remaining pathname elements to the list.
*/
for (;;) {
@@ -4048,10 +3937,6 @@ Tcl_FSSplitPath(
}
}
- /*
- * Compute the number of elements in the result.
- */
-
if (lenPtr != NULL) {
TclListObjLength(NULL, result, lenPtr);
}
@@ -4062,38 +3947,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,
@@ -4114,14 +3995,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.
*
@@ -4133,49 +4014,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)
@@ -4188,12 +4065,11 @@ TclFSNonnativePathType(
!= 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;
@@ -4205,7 +4081,7 @@ TclFSNonnativePathType(
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
- strVol = Tcl_GetStringFromObj(vol,&len);
+ strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
@@ -4227,7 +4103,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;
@@ -4245,12 +4121,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.
@@ -4260,10 +4137,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;
@@ -4286,27 +4162,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;
@@ -4328,15 +4204,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.
*
*---------------------------------------------------------------------------
*/
@@ -4344,8 +4219,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;
@@ -4356,7 +4231,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;
}
@@ -4364,7 +4239,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);
@@ -4372,8 +4247,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) {
@@ -4381,7 +4256,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);
@@ -4406,11 +4281,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.
@@ -4436,14 +4311,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.
*
*---------------------------------------------------------------------------
*/
@@ -4466,27 +4342,30 @@ 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;
@@ -4508,28 +4387,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);
@@ -4538,27 +4420,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,
@@ -4579,16 +4455,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.
*
*---------------------------------------------------------------------------
*/
@@ -4605,41 +4479,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 master filesystem. This is
- * accomplished by the FsGetFirstFilesystem() call.
- */
-
+ /* Start with an up-to-date copy of the master 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;
@@ -4648,10 +4519,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();
@@ -4668,26 +4539,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.
*
*---------------------------------------------------------------------------
*/
@@ -4704,7 +4556,7 @@ Tcl_FSGetNativePath(
*
* NativeFreeInternalRep --
*
- * Free a native internal representation, which will be non-NULL.
+ * Free a native internal representation.
*
* Results:
* None.
@@ -4726,16 +4578,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.
*
*---------------------------------------------------------------------------
*/
@@ -4771,16 +4624,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
*
*---------------------------------------------------------------------------
*/
@@ -4801,8 +4651,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, "/");
@@ -4814,11 +4664,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.
@@ -4828,9 +4678,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 b200f6f..4749e6e 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -100,6 +100,7 @@ typedef struct {
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(
@@ -113,6 +114,7 @@ Tcl_GetIndexFromObj(
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
+ if (!(flags & INDEX_TEMP_TABLE)) {
/*
* See if there is a valid cached result from a previous lookup (doing the
@@ -120,8 +122,10 @@ Tcl_GetIndexFromObj(
* the common case where the result is cached).
*/
- if (objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &indexType);
+
+ if (irPtr) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -134,9 +138,11 @@ Tcl_GetIndexFromObj(
return TCL_OK;
}
}
+ }
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -193,7 +199,7 @@ GetIndexFromObjList(
* Build a string table from the list.
*/
- tablePtr = ckalloc((objc + 1) * sizeof(char *));
+ tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *));
for (t = 0; t < objc; t++) {
if (objv[t] == objPtr) {
/*
@@ -210,13 +216,8 @@ GetIndexFromObjList(
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
- sizeof(char *), msg, flags, indexPtr);
-
- /*
- * The internal rep must be cleared since tablePtr will go away.
- */
+ sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr);
- TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
@@ -269,6 +270,7 @@ Tcl_GetIndexFromObjStruct(
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
+ const Tcl_ObjIntRep *irPtr;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
@@ -278,13 +280,16 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ if (!(flags & INDEX_TEMP_TABLE)) {
+ irPtr = TclFetchIntRep(objPtr, &indexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
+ }
/*
* Lookup the value of the object in the table. Accept unique
@@ -302,7 +307,7 @@ Tcl_GetIndexFromObjStruct(
* - Several abbreviations (never allowed, but overridden by exact match)
*/
- for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL;
+ for (entryPtr = (const char* const*)tablePtr, idx = 0; *entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
@@ -339,17 +344,21 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
- if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ if (!(flags & INDEX_TEMP_TABLE)) {
+ irPtr = TclFetchIntRep(objPtr, &indexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
} else {
- TclFreeIntRep(objPtr);
- indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->typePtr = &indexType;
+ Tcl_ObjIntRep ir;
+
+ indexRep = (IndexRep*)ckalloc(sizeof(IndexRep));
+ ir.twoPtrValue.ptr1 = indexRep;
+ Tcl_StoreIntRep(objPtr, &indexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
+ }
*indexPtr = index;
return TCL_OK;
@@ -363,7 +372,7 @@ Tcl_GetIndexFromObjStruct(
int count = 0;
TclNewObj(resultPtr);
- entryPtr = tablePtr;
+ entryPtr = (const char* const *)tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
@@ -414,16 +423,10 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
- register char *buf;
- register unsigned len;
- register const char *indexStr = EXPAND_OF(indexRep);
-
- len = strlen(indexStr);
- buf = ckalloc(len + 1);
- memcpy(buf, indexStr, len+1);
- objPtr->bytes = buf;
- objPtr->length = len;
+ IndexRep *indexRep = (IndexRep *)TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1;
+ const char *indexStr = EXPAND_OF(indexRep);
+
+ Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
@@ -449,12 +452,14 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1;
- IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
+ Tcl_ObjIntRep ir;
+ IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep));
+
+ memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1,
+ sizeof(IndexRep));
- memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
- dupPtr->typePtr = &indexType;
+ ir.twoPtrValue.ptr1 = dupIndexRep;
+ Tcl_StoreIntRep(dupPtr, &indexType, &ir);
}
/*
@@ -478,7 +483,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ ckfree(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -535,7 +540,7 @@ TclInitPrefixCmd(
static int
PrefixMatchObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -659,7 +664,7 @@ PrefixMatchObjCmd(
static int
PrefixAllObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -678,10 +683,10 @@ PrefixAllObjCmd(
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.
@@ -716,7 +721,7 @@ PrefixAllObjCmd(
static int
PrefixLongestObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -734,13 +739,13 @@ PrefixLongestObjCmd(
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
@@ -925,10 +930,10 @@ Tcl_WrongNumArgs(
/*
* Add the element, quoting it if necessary.
*/
+ const Tcl_ObjIntRep *irPtr;
- if (origObjv[i]->typePtr == &indexType) {
- register IndexRep *indexRep =
- origObjv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
@@ -939,8 +944,7 @@ Tcl_WrongNumArgs(
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
- char *quotedElementStr = TclStackAlloc(interp,
- (unsigned)len + 1);
+ char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
@@ -975,9 +979,10 @@ Tcl_WrongNumArgs(
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
+ const Tcl_ObjIntRep *irPtr;
- if (objv[i]->typePtr == &indexType) {
- register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchIntRep(objv[i], &indexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
@@ -990,8 +995,7 @@ Tcl_WrongNumArgs(
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
- char *quotedElementStr = TclStackAlloc(interp,
- (unsigned) len + 1);
+ char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
@@ -1069,14 +1073,14 @@ Tcl_ParseArgsObjv(
* successful exit. Will include the name of
* the command. */
int nrem; /* Size of leftovers.*/
- register const Tcl_ArgvInfo *infoPtr;
+ const Tcl_ArgvInfo *infoPtr;
/* Pointer to the current entry in the table
* of argument descriptions. */
const Tcl_ArgvInfo *matchPtr;
/* Descriptor that matches current argument */
Tcl_Obj *curArg; /* Current argument */
const char *str = NULL;
- register char c; /* Second character of current arg (used for
+ char c; /* Second character of current arg (used for
* quick check for matching; use 2nd char.
* because first char. will almost always be
* '-'). */
@@ -1097,7 +1101,7 @@ Tcl_ParseArgsObjv(
*/
nrem = 1;
- leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
+ leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
leftovers[0] = objv[0];
} else {
nrem = 0;
@@ -1115,7 +1119,7 @@ Tcl_ParseArgsObjv(
curArg = objv[srcIndex];
srcIndex++;
objc--;
- str = Tcl_GetStringFromObj(curArg, &length);
+ str = TclGetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
@@ -1281,7 +1285,7 @@ Tcl_ParseArgsObjv(
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
- *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
+ *remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
return TCL_OK;
/*
@@ -1324,7 +1328,7 @@ PrintUsage(
/* Array of command-specific argument
* descriptions. */
{
- register const Tcl_ArgvInfo *infoPtr;
+ const Tcl_ArgvInfo *infoPtr;
int width, numSpaces;
#define NUM_SPACES 20
static const char spaces[] = " ";
@@ -1424,7 +1428,7 @@ TclGetCompletionCodeFromObj(
"ok", "error", "return", "break", "continue", NULL
};
- if ((value->typePtr != &indexType)
+ if (!TclHasIntRep(value, &indexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 46adc69..8845359 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -50,7 +50,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)
}
@@ -114,7 +114,7 @@ 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)
@@ -151,7 +151,7 @@ declare 32 {
#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)
}
@@ -160,7 +160,7 @@ declare 34 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
-# Removed in 8.6a2
+# Removed in 8.6a2:
#declare 36 {
# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
#}
@@ -227,7 +227,7 @@ declare 51 {
#}
declare 53 {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char **argv)
+ int argc, const char **argv)
}
declare 54 {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
@@ -289,7 +289,7 @@ declare 64 {
# 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)
@@ -305,7 +305,7 @@ declare 69 {
# int TclpDeleteFile(const char *path)
#}
declare 74 {
- void TclpFree(char *ptr)
+ void TclpFree(void *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
@@ -313,9 +313,7 @@ declare 75 {
declare 76 {
unsigned long TclpGetSeconds(void)
}
-
-# deprecated
-declare 77 {
+declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
# Removed in 8.6:
@@ -332,7 +330,7 @@ declare 77 {
# char *modeString, int permissions)
#}
declare 81 {
- char *TclpRealloc(char *ptr, unsigned int size)
+ void *TclpRealloc(void *ptr, unsigned int size)
}
#declare 82 {
# int TclpRemoveDirectory(const char *path, int recursive,
@@ -357,7 +355,7 @@ declare 81 {
# declare 87 {
# void TclPlatformInit(Tcl_Interp *interp)
# }
-declare 88 {
+declare 88 {deprecated {}} {
char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags)
}
@@ -419,7 +417,7 @@ declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
-declare 104 {
+declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
# Replaced by Tcl_FSStat in 8.4:
@@ -455,26 +453,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,
+ Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
ClientData 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 {
@@ -490,28 +488,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 {
@@ -532,7 +530,7 @@ declare 131 {
declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
-declare 133 {
+declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
# Removed in 8.5
@@ -550,7 +548,7 @@ declare 133 {
# 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,
@@ -562,7 +560,7 @@ declare 138 {
#}
# 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,
@@ -625,12 +623,10 @@ declare 156 {
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 158 {
+declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptFileName(const char *filename)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 159 {
+declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
const char *TclGetStartupScriptFileName(void)
}
#declare 160 {
@@ -676,13 +672,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
@@ -730,12 +723,11 @@ 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
@@ -748,12 +740,10 @@ declare 179 {
# 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)
}
@@ -903,7 +893,7 @@ declare 227 {
# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
# core and NRE-enabled
# declare 228 {
-# int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj,
+# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
# int skip, ProcErrorProc *errorProc)
# }
declare 229 {
@@ -937,10 +927,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)
}
@@ -1009,7 +996,7 @@ declare 250 {
# 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.
@@ -1037,12 +1024,22 @@ declare 256 {
int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags)
}
-
declare 257 {
void TclStaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
+# TIP 431: temporary directory creation function
+declare 258 {
+ Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj)
+}
+
+declare 259 {
+ unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int *lengthPtr)
+}
+
declare 260 {
void TclUnusedStubEntry(void)
}
@@ -1099,7 +1096,7 @@ declare 9 win {
declare 10 win {
Tcl_DirEntry *TclpReaddir(TclDIR *dir)
}
-# Removed in 8.3.1 (for Win32s only)
+# Removed in 8.3.1 (for Win32s only):
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
#}
@@ -1149,7 +1146,6 @@ 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)
}
@@ -1283,7 +1279,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 dfb3dfe..afb431c 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,12 @@
#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
+#if !defined(STDC_HEADERS) && !defined(__STDC__) && !defined(__C99__FUNC__) \
+ && !defined(__cplusplus) && !defined(_MSC_VER) && !defined(__ICC)
typedef int ptrdiff_t;
#endif
+#include <stddef.h>
+#include <locale.h>
/*
* Ensure WORDS_BIGENDIAN is defined correctly:
@@ -82,19 +123,6 @@ 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".
@@ -103,19 +131,19 @@ typedef int ptrdiff_t;
#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))
+# define PTR2INT(p) ((intptr_t)(p))
# else
# define INT2PTR(p) ((void *)(p))
-# define PTR2INT(p) ((int)(p))
+# define PTR2INT(p) ((long)(p))
# endif
#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))
+# define PTR2UINT(p) ((uintptr_t)(p))
# else
# define UINT2PTR(p) ((void *)(p))
-# define PTR2UINT(p) ((unsigned int)(p))
+# define PTR2UINT(p) ((unsigned long)(p))
# endif
#endif
@@ -123,6 +151,26 @@ typedef int ptrdiff_t;
# define vsnprintf _vsnprintf
#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.
@@ -147,13 +195,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, int 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 {
@@ -235,7 +283,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
@@ -252,7 +300,7 @@ typedef struct Namespace {
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
- long nsId; /* Unique id for the namespace. */
+ 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
@@ -261,7 +309,7 @@ typedef struct Namespace {
* 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
+ unsigned int 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
@@ -286,12 +334,12 @@ typedef struct Namespace {
* registered using "namespace export". */
int maxExportPatterns; /* Mumber of export patterns for which space
* is currently allocated. */
- int cmdRefEpoch; /* Incremented if a newly added command
+ unsigned int 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
+ unsigned int 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
@@ -318,7 +366,7 @@ typedef struct Namespace {
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
- int exportLookupEpoch; /* Incremented whenever a command is added to
+ unsigned int 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
@@ -419,7 +467,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
+ unsigned int 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
@@ -506,7 +554,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,
@@ -525,14 +573,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
+ unsigned int 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. */
@@ -605,7 +653,7 @@ typedef struct Var {
typedef struct VarInHash {
Var var;
- int refCount; /* Counts number of active uses of this
+ unsigned int 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
@@ -917,7 +965,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[1]; /* Name of the local variable starts here. If
@@ -936,7 +984,7 @@ typedef struct CompiledLocal {
typedef struct Proc {
struct Interp *iPtr; /* Interpreter for which this command is
* defined. */
- int refCount; /* Reference count: 1 if still present in
+ unsigned int 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
@@ -978,7 +1026,7 @@ typedef struct Trace {
int level; /* Only trace commands at nesting level less
* than or equal to this. */
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
- ClientData clientData; /* Arbitrary value to pass to proc. */
+ void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
@@ -1030,7 +1078,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;
/*
@@ -1053,7 +1101,7 @@ typedef struct AssocData {
*/
typedef struct LocalCache {
- int refCount;
+ unsigned int refCount;
int numVars;
Tcl_Obj *varName0;
} LocalCache;
@@ -1108,7 +1156,7 @@ typedef struct CallFrame {
* 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
@@ -1132,6 +1180,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
@@ -1215,7 +1267,7 @@ 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
+ unsigned int refCount; /* Number of times the word is on the
* stack. */
} CFWord;
@@ -1292,13 +1344,13 @@ 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 {
@@ -1343,7 +1395,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))
/*
*----------------------------------------------------------------
@@ -1478,11 +1530,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
+ unsigned int 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, (unsigned)-1. */
Namespace *nsPtr; /* Namespace in which this literal is used. We
* try to avoid sharing literal non-FQ command
* names among different namespaces to reduce
@@ -1496,13 +1548,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
+ unsigned int numBuckets; /* Total number of buckets allocated at
* **buckets. */
- int numEntries; /* Total number of entries present in
+ unsigned int numEntries; /* Total number of entries present in
* table. */
- int rebuildSize; /* Enlarge table when numEntries gets to be
+ unsigned int rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
- int mask; /* Mask value used in hashing function. */
+ unsigned int mask; /* Mask value used in hashing function. */
} LiteralTable;
/*
@@ -1513,10 +1565,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. */
@@ -1524,10 +1576,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. */
@@ -1535,11 +1587,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 */
@@ -1554,7 +1606,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;
@@ -1620,24 +1672,24 @@ typedef struct Command {
* recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
- int refCount; /* 1 if in command hashtable plus 1 for each
+ unsigned int 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
+ unsigned int 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
@@ -1803,7 +1855,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 master/slave interps on a
* per-interp basis. */
union {
@@ -1848,6 +1900,7 @@ typedef struct Interp {
* See Tcl_AppendResult code for details.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
@@ -1855,6 +1908,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.
@@ -1884,7 +1942,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
+ unsigned int 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
@@ -1916,8 +1974,14 @@ 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 TCL_MAJOR_VERSION < 9
+# 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
+#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
@@ -2311,6 +2375,13 @@ typedef struct Interp {
#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
/*
+ * A common panic alert when memory allocation fails.
+ */
+
+#define TclOOM(ptr, size) \
+ ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1)))
+
+/*
* The following enum values are used to specify the runtime platform setting
* of the tclPlatform variable.
*/
@@ -2361,7 +2432,7 @@ typedef enum TclEolTranslation {
*/
typedef struct List {
- int refCount;
+ unsigned 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
@@ -2384,12 +2455,6 @@ typedef struct List {
#define ListRepPtr(listPtr) \
((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
-#define ListSetIntRep(objPtr, listRepPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
- (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
- (listRepPtr)->refCount++, \
- (objPtr)->typePtr = &tclListType
-
#define ListObjGetElements(listPtr, objc, objv) \
((objv) = &(ListRepPtr(listPtr)->elements), \
(objc) = ListRepPtr(listPtr)->elemCount)
@@ -2422,40 +2487,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, boolPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
+ : ((objPtr)->typePtr == &tclBooleanType) \
+ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
+ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
+
+#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
@@ -2465,21 +2535,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().
@@ -2545,6 +2605,15 @@ typedef struct TclFileAttrProcs {
} TclFileAttrProcs;
/*
+ * Private flag value which controls Tcl_GetIndexFromObj*() routines
+ * to instruct them not to cache lookups because the table will not
+ * live long enough to make it worthwhile. Must not clash with public
+ * flag value TCL_EXACT.
+ */
+
+#define INDEX_TEMP_TABLE 2
+
+/*
* Opaque handle used in pipeline routines to encapsulate platform-dependent
* state.
*/
@@ -2594,7 +2663,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
*----------------------------------------------------------------
*/
-typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
+typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
@@ -2606,9 +2675,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
*/
typedef struct ProcessGlobalValue {
- int epoch; /* Epoch counter to detect changes in the
+ unsigned int epoch; /* Epoch counter to detect changes in the
* master value. */
- int numBytes; /* Length of the master string. */
+ unsigned int numBytes; /* Length of the master string. */
char *value; /* The master string value. */
Tcl_Encoding encoding; /* system encoding when master string was
* initialized. */
@@ -2644,6 +2713,8 @@ 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 */
/*
*----------------------------------------------------------------------
@@ -2651,8 +2722,11 @@ typedef struct ProcessGlobalValue {
*----------------------------------------------------------------------
*/
-#define TCL_NUMBER_LONG 1
-#define TCL_NUMBER_WIDE 2
+#define TCL_NUMBER_INT 2
+#if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED)
+# define TCL_NUMBER_LONG 1 /* deprecated, not used any more */
+# define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */
+#endif
#define TCL_NUMBER_BIG 3
#define TCL_NUMBER_DOUBLE 4
#define TCL_NUMBER_NAN 5
@@ -2689,17 +2763,12 @@ 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 tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
-MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
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;
@@ -2720,10 +2789,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 */
/*
@@ -2732,7 +2801,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
* shared by all new objects allocated by Tcl_NewObj.
*/
-MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
enum CheckEmptyStringResult {
@@ -2805,7 +2873,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
@@ -2819,29 +2887,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 */
/*
*----------------------------------------------------------------
@@ -2868,11 +2926,11 @@ 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 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,
@@ -2884,6 +2942,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,
@@ -2893,25 +2953,19 @@ 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, ClientData 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 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);
@@ -2922,6 +2976,7 @@ 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 void TclCreateLateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
@@ -2932,12 +2987,10 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
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_Namespace * TclEnsureNamespace(
- 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);
@@ -2955,23 +3008,20 @@ 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,
+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 int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
@@ -2983,6 +3033,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 Proc * TclGetLambdaFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr);
MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData *clientDataPtr,
int *typePtr);
@@ -2994,6 +3046,11 @@ 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 TclGetLoadedPackagesEx(Tcl_Interp *interp,
+ const char *targetName,
+ const char *packageName);
+MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
+ Tcl_WideInt *);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
@@ -3023,8 +3080,8 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
-MODULE_SCOPE void 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);
@@ -3038,6 +3095,8 @@ 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 Tcl_Obj * TclListObjRange(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,
@@ -3053,7 +3112,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,
@@ -3065,6 +3123,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);
@@ -3092,7 +3152,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
int stackSize, int flags);
MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
- int *lengthPtr, Tcl_Encoding *encodingPtr);
+ unsigned int *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void TclpInitLock(void);
MODULE_SCOPE void TclpInitPlatform(void);
MODULE_SCOPE void TclpInitUnlock(void);
@@ -3120,6 +3180,8 @@ 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,
@@ -3128,7 +3190,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);
@@ -3141,8 +3203,9 @@ MODULE_SCOPE int TclScanElement(const char *string, int length,
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumIntRep(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);
@@ -3154,17 +3217,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);
@@ -3182,25 +3244,26 @@ 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 TclUCS4Complete Tcl_UtfCharComplete
+# define TclChar16Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
+ ? ((length) >= 3) : Tcl_UtfCharComplete((src), (length)))
+#else
+ MODULE_SCOPE int TclUtfToUCS4(const char *src, int *ucs4Ptr);
+ MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *src, int *ucs4Ptr);
+# define TclUCS4Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
+ ? ((length) >= 4) : Tcl_UtfCharComplete((src), (length)))
+# define TclChar16Complete Tcl_UtfCharComplete
#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 * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
@@ -3244,8 +3307,11 @@ MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
+MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp,
+ const char *msg, int length);
+/* Tip 430 */
+MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
-MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
/*
* Many parsing tasks need a common definition of whitespace.
@@ -3277,9 +3343,11 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+#endif
MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3299,7 +3367,7 @@ MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
MODULE_SCOPE int TclClockOldscanObjCmd(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -3335,7 +3403,6 @@ MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3364,7 +3431,6 @@ MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
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[]);
@@ -3426,9 +3492,15 @@ MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LpopObjCmd(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_LremoveObjCmd(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[]);
@@ -3603,6 +3675,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);
@@ -3765,6 +3840,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);
@@ -3994,12 +4072,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.
@@ -4050,11 +4163,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 TclSlaveObjCmd;
+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].
*/
@@ -4063,13 +4220,9 @@ 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)
/*
*----------------------------------------------------------------
@@ -4128,7 +4281,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)
@@ -4145,8 +4298,8 @@ 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; \
TclFreeObjStorage(objPtr); \
@@ -4156,6 +4309,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)
/*
@@ -4169,11 +4326,11 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
(objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
- ckfree((char *) (objPtr))
+ ckfree(objPtr)
#undef USE_THREAD_ALLOC
#undef USE_TCLALLOC
-#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#elif TCL_THREADS && defined(USE_THREAD_ALLOC)
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
@@ -4187,6 +4344,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 *);
/*
@@ -4208,7 +4366,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
- cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \
+ cachePtr->firstObjPtr = (Tcl_Obj *)(objPtr)->internalRep.twoPtrValue.ptr1; \
--cachePtr->numObjects; \
} \
} while (0)
@@ -4237,7 +4395,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
@@ -4305,11 +4463,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
- (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
- memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \
+ (objPtr)->bytes = (char *) ckalloc((len) + 1); \
+ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
@@ -4327,7 +4485,7 @@ 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))
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
@@ -4362,14 +4520,66 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclInvalidateStringRep(objPtr) \
- if (objPtr->bytes != NULL) { \
- if (objPtr->bytes != tclEmptyStringRep) { \
- ckfree((char *) objPtr->bytes); \
+ if ((objPtr)->bytes != NULL) { \
+ if ((objPtr)->bytes != &tclEmptyString) { \
+ ckfree((objPtr)->bytes); \
} \
- objPtr->bytes = NULL; \
+ (objPtr)->bytes = NULL; \
}
/*
+ * 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
@@ -4417,19 +4627,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; \
} \
@@ -4452,10 +4662,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) \
+ ((((unsigned char) *(str)) < 0x80) ? \
+ ((*(chPtr) = (unsigned char) *(str)), 1) \
+ : Tcl_UtfToChar16(str, chPtr))
+#endif
/*
*----------------------------------------------------------------
@@ -4482,8 +4699,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
} while (0);
#define TclUtfPrev(src, start) \
- (((src) < (start)+2) ? (start) : \
- (UCHAR(*((src) - 1))) < 0x80 ? (src)-1 : \
+ (((src) < (start) + 2) ? (start) : \
+ ((unsigned char) *((src) - 1)) < 0x80 ? (src) - 1 : \
Tcl_UtfPrev(src, start))
/*
@@ -4501,13 +4718,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 TclHasIntRep(objPtr, type) \
+ ((objPtr)->typePtr == (type))
+#define TclFetchIntRep(objPtr, type) \
+ (TclHasIntRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL)
-#define TclIsPureList(objPtr) \
- (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclListType))
/*
*----------------------------------------------------------------
@@ -4589,51 +4807,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, long boolValue);
- * 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_ObjIntRep ir; \
+ ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.longValue = (long)(i); \
- (objPtr)->typePtr = &tclIntType; \
+ Tcl_StoreIntRep(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_ObjIntRep ir; \
+ ir.doubleValue = (double) d; \
+ TclInvalidateStringRep(objPtr); \
+ Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
@@ -4642,39 +4834,26 @@ 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)
-
-/*
- * 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 TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
@@ -4697,14 +4876,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
-#define TclNewIntObj(objPtr, i) \
- (objPtr) = Tcl_NewIntObj(i)
-
-#define TclNewLongObj(objPtr, l) \
- (objPtr) = Tcl_NewLongObj(l)
-
-#define TclNewBooleanObj(objPtr, b) \
- (objPtr) = Tcl_NewBooleanObj(b)
+#define TclNewIntObj(objPtr, w) \
+ (objPtr) = Tcl_NewWideIntObj(w)
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
@@ -4757,15 +4930,16 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
#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))
+#ifndef TCL_NO_DEPRECATED
+# 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
/*
@@ -4787,7 +4961,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
#define TclCleanupCommandMacro(cmdPtr) \
if ((cmdPtr)->refCount-- <= 1) { \
- ckfree((char *) (cmdPtr));\
+ ckfree(cmdPtr);\
}
/*
@@ -4851,7 +5025,7 @@ 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) \
@@ -4866,7 +5040,7 @@ 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) \
@@ -4945,7 +5119,7 @@ typedef struct NRE_callback {
#else
#define TCLNR_ALLOC(interp, ptr) \
(ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
-#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
+#define TCLNR_FREE(interp, ptr) ckfree(ptr)
#endif
#if NRE_ENABLE_ASSERTS
@@ -4956,7 +5130,6 @@ typedef struct NRE_callback {
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
-#include "tclTomMathDecls.h"
#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
#define Tcl_AttemptAlloc(size) TclpAlloc(size)
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 7560d11..2426326 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 */
@@ -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 */
@@ -172,7 +175,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp);
/* 53 */
EXTERN int TclInvokeObjectCommand(ClientData clientData,
Tcl_Interp *interp, int argc,
- CONST84 char **argv);
+ const char **argv);
/* 54 */
EXTERN int TclInvokeStringCommand(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -205,24 +208,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, unsigned int size);
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
@@ -230,7 +234,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(ClientData clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
/* 89 */
@@ -266,7 +271,8 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp);
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 +289,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,
+EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
const char *name, ClientData 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 +319,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);
@@ -349,19 +355,18 @@ EXTERN void Tcl_SetNamespaceResolvers(
/* 132 */
EXTERN 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,
@@ -400,9 +405,11 @@ 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,
@@ -421,9 +428,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 +465,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 */
@@ -569,7 +580,8 @@ 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 */
@@ -614,7 +626,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags,
EXTERN void TclSetSlaveCancelFlags(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,
@@ -643,8 +655,12 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
-/* Slot 258 is reserved */
-/* Slot 259 is reserved */
+/* 258 */
+EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj);
+/* 259 */
+EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *lengthPtr);
/* 260 */
EXTERN void TclUnusedStubEntry(void);
@@ -660,7 +676,7 @@ 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 */
@@ -676,7 +692,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 +702,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 */
@@ -705,7 +721,7 @@ 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 (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */
int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
@@ -721,26 +737,26 @@ typedef struct TclIntStubs {
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, unsigned int 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) (ClientData 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 */
@@ -756,7 +772,7 @@ typedef struct TclIntStubs {
CONST86 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,36 +780,36 @@ 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, ClientData 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("") 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 */
+ const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
@@ -810,8 +826,8 @@ 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 */
@@ -819,8 +835,8 @@ typedef struct TclIntStubs {
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 +846,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,7 +904,7 @@ typedef struct TclIntStubs {
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
+ TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
@@ -903,15 +919,15 @@ typedef struct TclIntStubs {
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt 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 */
+ 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, const int flags); /* 252 */
Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const 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, const int flags); /* 256 */
void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
- void (*reserved258)(void);
- void (*reserved259)(void);
+ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
+ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 259 */
void (*tclUnusedStubEntry) (void); /* 260 */
} TclIntStubs;
@@ -1100,38 +1116,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 \
@@ -1222,10 +1238,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 \
@@ -1356,8 +1372,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
#define TclStaticPackage \
(tclIntStubsPtr->tclStaticPackage) /* 257 */
-/* Slot 258 is reserved */
-/* Slot 259 is reserved */
+#define TclpCreateTemporaryDirectory \
+ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
+#define TclGetBytesFromObj \
+ (tclIntStubsPtr->tclGetBytesFromObj) /* 259 */
#define TclUnusedStubEntry \
(tclIntStubsPtr->tclUnusedStubEntry) /* 260 */
@@ -1368,58 +1386,31 @@ 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) && 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 */
+#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_StaticPackage
+# define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage)
#endif
-#undef TclCopyChannelOld
-#undef TclSockMinimumBuffersOld
-
#endif /* _TCLINTDECLS */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 7034fc3..669baae 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;
@@ -588,10 +588,18 @@ 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))
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index ac66324..1570837 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -222,18 +222,12 @@ static int AliasDelete(Tcl_Interp *interp,
static int AliasDescribe(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, Tcl_Obj *objPtr);
static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
-static int AliasObjCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
-static int AliasNRCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
-static void AliasObjCmdDeleteProc(ClientData clientData);
+static Tcl_ObjCmdProc AliasNRCmd;
+static Tcl_CmdDeleteProc AliasObjCmdDeleteProc;
static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-static void InterpInfoDeleteProc(ClientData clientData,
- Tcl_Interp *interp);
+static Tcl_InterpDeleteProc InterpInfoDeleteProc;
static int SlaveBgerror(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
Tcl_Obj *const objv[]);
@@ -257,9 +251,7 @@ static int SlaveInvokeHidden(Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int SlaveMarkTrusted(Tcl_Interp *interp,
Tcl_Interp *slaveInterp);
-static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static void SlaveObjCmdDeleteProc(ClientData clientData);
+static Tcl_CmdDeleteProc SlaveObjCmdDeleteProc;
static int SlaveRecursionLimit(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
Tcl_Obj *const objv[]);
@@ -331,13 +323,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;
}
}
@@ -382,7 +385,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"
@@ -403,6 +406,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"
@@ -410,6 +414,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"
@@ -444,7 +449,11 @@ Tcl_Init(
" error $msg\n"
" }\n"
"}\n"
-"tclInit");
+"tclInit", -1, 0);
+
+end:
+ *names = (*names)->nextPtr;
+ return result;
}
/*
@@ -473,7 +482,7 @@ TclInterpInit(
Master *masterPtr;
Slave *slavePtr;
- interpInfoPtr = ckalloc(sizeof(InterpInfo));
+ interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
masterPtr = &interpInfoPtr->master;
@@ -513,7 +522,7 @@ TclInterpInit(
static void
InterpInfoDeleteProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* slave interps should already be deleted. */
{
@@ -589,10 +598,10 @@ InterpInfoDeleteProc(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
+
int
Tcl_InterpObjCmd(
- ClientData clientData, /* Unused. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -602,7 +611,7 @@ Tcl_InterpObjCmd(
static int
NRInterpCmd(
- ClientData clientData, /* Unused. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1023,7 +1032,7 @@ NRInterpCmd(
resultPtr = Tcl_NewObj();
hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
- string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
+ string = (char *)Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(string, -1));
}
@@ -1094,7 +1103,7 @@ NRInterpCmd(
NULL);
return TCL_ERROR;
}
- aliasPtr = Tcl_GetHashValue(hPtr);
+ aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"target interpreter for alias \"%s\" in path \"%s\" is "
@@ -1177,7 +1186,7 @@ Tcl_CreateAlias(
int i;
int result;
- objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc);
+ objv = (Tcl_Obj **)TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
@@ -1283,7 +1292,7 @@ Tcl_GetAlias(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
- aliasPtr = Tcl_GetHashValue(hPtr);
+ aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
@@ -1345,7 +1354,7 @@ Tcl_GetAliasObj(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
- aliasPtr = Tcl_GetHashValue(hPtr);
+ aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
@@ -1403,7 +1412,8 @@ TclPreventAliasLoop(
* create or rename the command.
*/
- if (cmdPtr->objProc != AliasObjCmd) {
+ if (cmdPtr->objProc != TclAliasObjCmd
+ && cmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
@@ -1413,7 +1423,7 @@ TclPreventAliasLoop(
* chain then we have a loop.
*/
- aliasPtr = cmdPtr->objClientData;
+ aliasPtr = (Alias *)cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
@@ -1458,13 +1468,12 @@ TclPreventAliasLoop(
* Otherwise we do not have a loop.
*/
- if (aliasCmdPtr->objProc != AliasObjCmd) {
+ if (aliasCmdPtr->objProc != TclAliasObjCmd
+ && aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
- nextAliasPtr = aliasCmdPtr->objClientData;
+ nextAliasPtr = (Alias *)aliasCmdPtr->objClientData;
}
-
- /* NOTREACHED */
}
/*
@@ -1504,7 +1513,7 @@ AliasCreate(
Tcl_Obj **prefv;
int isNew, i;
- aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
+ aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = masterInterp;
@@ -1524,12 +1533,12 @@ AliasCreate(
if (slaveInterp == masterInterp) {
aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
+ aliasPtr, AliasObjCmdDeleteProc);
} else {
- aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
+ TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
}
if (TclPreventAliasLoop(interp, slaveInterp,
@@ -1612,7 +1621,7 @@ AliasCreate(
* interp alias {} foo {} zop # Now recreate "foo"...
*/
- targetPtr = ckalloc(sizeof(Target));
+ targetPtr = (Target *)ckalloc(sizeof(Target));
targetPtr->slaveCmd = aliasPtr->slaveCmd;
targetPtr->slaveInterp = slaveInterp;
@@ -1673,7 +1682,7 @@ AliasDelete(
TclGetString(namePtr), NULL);
return TCL_ERROR;
}
- aliasPtr = Tcl_GetHashValue(hPtr);
+ aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
return TCL_OK;
}
@@ -1718,7 +1727,7 @@ AliasDescribe(
if (hPtr == NULL) {
return TCL_OK;
}
- aliasPtr = Tcl_GetHashValue(hPtr);
+ aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
@@ -1755,7 +1764,7 @@ AliasList(
entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
- aliasPtr = Tcl_GetHashValue(entryPtr);
+ aliasPtr = (Alias *)Tcl_GetHashValue(entryPtr);
Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
}
Tcl_SetObjResult(interp, resultPtr);
@@ -1765,7 +1774,7 @@ AliasList(
/*
*----------------------------------------------------------------------
*
- * AliasObjCmd --
+ * TclAliasObjCmd, TclLocalAliasObjCmd --
*
* This is the function that services invocations of aliases in a slave
* interpreter. One such command exists for each alias. When invoked,
@@ -1773,6 +1782,11 @@ AliasList(
* master 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.
*
@@ -1791,7 +1805,7 @@ AliasNRCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
- Alias *aliasPtr = clientData;
+ Alias *aliasPtr = (Alias *)clientData;
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
@@ -1808,13 +1822,13 @@ AliasNRCmd(
cmdc = prefc + objc - 1;
listPtr = Tcl_NewListObj(cmdc, NULL);
- listRep = listPtr->internalRep.twoPtrValue.ptr1;
+ listRep = ListRepPtr(listPtr);
listRep->elemCount = cmdc;
cmdv = &listRep->elements;
prefv = &aliasPtr->objPtr;
- memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
- memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * 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]);
@@ -1832,15 +1846,15 @@ 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. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
- Alias *aliasPtr = clientData;
+ Alias *aliasPtr = (Alias *)clientData;
Tcl_Interp *targetInterp = aliasPtr->targetInterp;
int result, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
@@ -1859,11 +1873,11 @@ AliasObjCmd(
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
- cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
+ cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
- memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
- memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+ memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
+ memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
Tcl_ResetResult(targetInterp);
@@ -1922,6 +1936,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
+}
/*
*----------------------------------------------------------------------
@@ -1945,7 +2026,7 @@ static void
AliasObjCmdDeleteProc(
ClientData clientData) /* The alias record for this alias. */
{
- Alias *aliasPtr = clientData;
+ Alias *aliasPtr = (Alias *)clientData;
Target *targetPtr;
int i;
Tcl_Obj **objv;
@@ -2121,7 +2202,7 @@ TclSetSlaveCancelFlags(
hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
- slavePtr = Tcl_GetHashValue(hPtr);
+ slavePtr = (Slave *)Tcl_GetHashValue(hPtr);
iPtr = (Interp *) slavePtr->slaveInterp;
if (iPtr == NULL) {
@@ -2186,7 +2267,7 @@ Tcl_GetInterpPath(
return TCL_ERROR;
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
- Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable,
+ Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->master.slaveTable,
iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
}
@@ -2234,7 +2315,7 @@ GetInterp(
searchInterp = NULL;
break;
}
- slavePtr = Tcl_GetHashValue(hPtr);
+ slavePtr = (Slave *)Tcl_GetHashValue(hPtr);
searchInterp = slavePtr->slaveInterp;
if (searchInterp == NULL) {
break;
@@ -2361,10 +2442,10 @@ SlaveCreate(
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
- SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
+ TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
- Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
@@ -2429,7 +2510,7 @@ SlaveCreate(
/*
*----------------------------------------------------------------------
*
- * SlaveObjCmd --
+ * TclSlaveObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each slave interpreter.
@@ -2443,8 +2524,8 @@ SlaveCreate(
*----------------------------------------------------------------------
*/
-static int
-SlaveObjCmd(
+int
+TclSlaveObjCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -2460,7 +2541,7 @@ NRSlaveCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Interp *slaveInterp = clientData;
+ Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "debug",
@@ -2476,7 +2557,7 @@ NRSlaveCmd(
};
if (slaveInterp == NULL) {
- Tcl_Panic("SlaveObjCmd: interpreter has been deleted");
+ Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted");
}
if (objc < 2) {
@@ -2664,7 +2745,7 @@ SlaveObjCmdDeleteProc(
ClientData clientData) /* The SlaveRecord for the command. */
{
Slave *slavePtr; /* Interim storage for Slave record. */
- Tcl_Interp *slaveInterp = clientData;
+ Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData;
/* And for a slave interp. */
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
@@ -2923,7 +3004,7 @@ SlaveRecursionLimit(
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(slaveInterp, 0);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
@@ -3004,7 +3085,7 @@ SlaveHidden(
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_ListObjAppendElement(NULL, listObjPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
+ Tcl_NewStringObj((const char *)Tcl_GetHashKey(hTblPtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, listObjPtr);
@@ -3192,12 +3273,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", master,
- "::tcl::mathfunc::min", 0, NULL);
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master,
- "::tcl::mathfunc::max", 0, NULL);
+ (void) Tcl_EvalEx(interp,
+ "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0);
}
iPtr->flags |= SAFE_INTERP;
@@ -3211,7 +3288,7 @@ Tcl_MakeSafe(
* No env array in a safe slave.
*/
- Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
@@ -3227,9 +3304,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
@@ -3282,7 +3359,7 @@ int
Tcl_LimitExceeded(
Tcl_Interp *interp)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
return iPtr->limit.exceeded != 0;
}
@@ -3313,10 +3390,10 @@ int
Tcl_LimitReady(
Tcl_Interp *interp)
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (iPtr->limit.active != 0) {
- register int ticker = ++iPtr->limit.granularityTicker;
+ int ticker = ++iPtr->limit.granularityTicker;
if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
((iPtr->limit.cmdGranularity == 1) ||
@@ -3360,7 +3437,7 @@ Tcl_LimitCheck(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
- register int ticker = iPtr->limit.granularityTicker;
+ int ticker = iPtr->limit.granularityTicker;
if (Tcl_InterpDeleted(interp)) {
return TCL_OK;
@@ -3519,15 +3596,12 @@ 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.
*/
- handlerPtr = ckalloc(sizeof(LimitHandler));
+ handlerPtr = (LimitHandler *)ckalloc(sizeof(LimitHandler));
handlerPtr->flags = 0;
handlerPtr->handlerProc = handlerProc;
handlerPtr->clientData = clientData;
@@ -3984,8 +4058,8 @@ static void
TimeLimitCallback(
ClientData clientData)
{
- Tcl_Interp *interp = clientData;
- Interp *iPtr = clientData;
+ Tcl_Interp *interp = (Tcl_Interp *)clientData;
+ Interp *iPtr = (Interp *)clientData;
int code;
Tcl_Preserve(interp);
@@ -4128,7 +4202,7 @@ static void
DeleteScriptLimitCallback(
ClientData clientData)
{
- ScriptLimitCallback *limitCBPtr = clientData;
+ ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
Tcl_DecrRefCount(limitCBPtr->scriptObj);
if (limitCBPtr->entryPtr != NULL) {
@@ -4158,9 +4232,9 @@ DeleteScriptLimitCallback(
static void
CallScriptLimitCallback(
ClientData clientData,
- Tcl_Interp *interp) /* Interpreter which failed the limit */
+ TCL_UNUSED(Tcl_Interp *))
{
- ScriptLimitCallback *limitCBPtr = clientData;
+ ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
int code;
if (Tcl_InterpDeleted(limitCBPtr->interp)) {
@@ -4228,13 +4302,13 @@ SetScriptLimitCallback(
hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
- limitCBPtr = Tcl_GetHashValue(hashPtr);
+ limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hashPtr);
limitCBPtr->entryPtr = NULL;
Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
limitCBPtr);
}
- limitCBPtr = ckalloc(sizeof(ScriptLimitCallback));
+ limitCBPtr = (ScriptLimitCallback *)ckalloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
@@ -4423,7 +4497,7 @@ SlaveCommandLimitCmd(
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
+ limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
@@ -4439,12 +4513,12 @@ SlaveCommandLimitCmd(
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
+ Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp,
TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp)));
+ Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp)));
} else {
Tcl_Obj *empty;
@@ -4465,20 +4539,20 @@ SlaveCommandLimitCmd(
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
+ limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS)));
break;
case OPT_VAL:
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
Tcl_SetObjResult(interp,
- Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp)));
+ Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp)));
}
break;
}
@@ -4499,7 +4573,7 @@ SlaveCommandLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
+ (void) TclGetStringFromObj(scriptObj, &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4516,7 +4590,7 @@ SlaveCommandLimitCmd(
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;
}
@@ -4611,7 +4685,7 @@ SlaveTimeLimitCmd(
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
+ limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
@@ -4626,7 +4700,7 @@ SlaveTimeLimitCmd(
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
+ Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp,
TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
@@ -4634,9 +4708,9 @@ SlaveTimeLimitCmd(
Tcl_LimitGetTime(slaveInterp, &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;
@@ -4659,14 +4733,14 @@ SlaveTimeLimitCmd(
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
+ limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME)));
break;
case OPT_MILLI:
@@ -4675,7 +4749,7 @@ SlaveTimeLimitCmd(
Tcl_LimitGetTime(slaveInterp, &limitMoment);
Tcl_SetObjResult(interp,
- Tcl_NewLongObj(limitMoment.usec/1000));
+ Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
@@ -4683,7 +4757,7 @@ SlaveTimeLimitCmd(
Tcl_Time limitMoment;
Tcl_LimitGetTime(slaveInterp, &limitMoment);
- Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec));
}
break;
}
@@ -4708,7 +4782,7 @@ SlaveTimeLimitCmd(
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];
@@ -4725,7 +4799,7 @@ SlaveTimeLimitCmd(
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;
}
@@ -4743,7 +4817,7 @@ SlaveTimeLimitCmd(
break;
case OPT_SEC:
secObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &secLen);
+ (void) TclGetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 4850d02..95844a0 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -8,12 +8,16 @@
*
* Copyright (c) 1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 2008 Rene Zaumseil
+ * 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.
*/
#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,10 +80,16 @@ 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:
@@ -68,9 +98,24 @@ typedef struct Link {
static char * LinkTraceProc(ClientData 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,241 @@ 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)
+{
+ Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
+ ClientData clientData;
+ int type, intValue;
+
+ if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
+ if (type == TCL_NUMBER_INT) {
+ *widePtr = *((const Tcl_WideInt *) clientData);
+ return (*widePtr < 0);
+ } else if (type == TCL_NUMBER_BIG) {
+ mp_int *numPtr = (mp_int *)clientData;
+ Tcl_WideUInt value = 0;
+ union {
+ Tcl_WideUInt value;
+ unsigned char bytes[sizeof(Tcl_WideUInt)];
+ } scratch;
+ size_t numBytes;
+ unsigned char *bytes = scratch.bytes;
+
+ if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr,
+ bytes, sizeof(Tcl_WideUInt), &numBytes))) {
+ /*
+ * If the sign bit is set (a negative value) or if the value
+ * can't possibly fit in the bits of an unsigned wide, there's
+ * no point in doing further conversion.
+ */
+ return 1;
+ }
+#ifdef WORDS_BIGENDIAN
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+#else /* !WORDS_BIGENDIAN */
+ /*
+ * Little-endian can read the value directly.
+ */
+ value = scratch.value;
+#endif /* WORDS_BIGENDIAN */
+ *uwidePtr = value;
+ return 0;
+ }
+ }
+
+ /*
+ * Evil edge case fallback.
+ */
+
+ 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_ObjIntRep *irPtr = TclFetchIntRep(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
+ || (TclIsNaN(a) && TclIsNaN(b))
+#endif /* ACCEPT_NAN */
+ ;
+}
+
+static inline int
+IsSpecial(
+ double a)
+{
+ return TclIsInfinite(a)
+#ifdef ACCEPT_NAN
+ || TclIsNaN(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;
+
+ str = TclGetString(objPtr);
+ if ((objPtr->length == 1) && (str[0] == '.')) {
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = 0.0;
+ return TCL_OK;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->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);
+ TclFreeIntRep(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)
+{
+ const char *str = TclGetString(objPtr);
+
+ if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0')
+ && strchr("xXbBoOdD", str[1]))) {
+ *intPtr = 0;
+ return TCL_OK;
+ } else if ((objPtr->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 (TclHasIntRep(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,
@@ -270,19 +745,26 @@ static char *
LinkTraceProc(
ClientData 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 +774,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 +801,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 +890,377 @@ LinkTraceProc(
return (char *) "internal error: linked variable couldn't be read";
}
+ /*
+ * Special cases.
+ */
+
+ switch (linkPtr->type) {
+ case TCL_LINK_STRING:
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length + 1;
+ pp = (char **) linkPtr->addr;
+
+ *pp = (char *)ckrealloc(*pp, valueLength);
+ memcpy(*pp, value, valueLength);
+ return NULL;
+
+ case TCL_LINK_CHARS:
+ value = (char *) Tcl_GetStringFromObj(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, (size_t) valueLength);
+ memcpy(linkPtr->addr, value, (size_t) 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, (size_t) valueLength);
+ memcpy(linkPtr->addr, value, (size_t) 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 (Tcl_ListObjGetElements(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, 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, 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, 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, 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, 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, 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 +1287,183 @@ 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++) {
+ objv[i] = Tcl_NewIntObj(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);
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++) {
+ objv[i] = Tcl_NewWideIntObj(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++) {
+ objv[i] = Tcl_NewDoubleObj(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++) {
+ objv[i] = Tcl_NewIntObj(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);
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++) {
+ objv[i] = Tcl_NewIntObj(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);
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++) {
+ objv[i] = Tcl_NewIntObj(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);
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++) {
+ objv[i] = Tcl_NewIntObj(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);
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++) {
+ objv[i] = Tcl_NewWideIntObj(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++) {
+ objv[i] = Tcl_NewWideIntObj(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++) {
+ objv[i] = Tcl_NewWideIntObj(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++) {
+ objv[i] = Tcl_NewDoubleObj(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:
+ 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_NewWideIntObj((Tcl_WideInt)
+ 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);
+
case TCL_LINK_STRING:
p = LinkedVar(char *);
if (p == NULL) {
@@ -636,6 +1472,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 +1501,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 6eb6780..1fcdea4 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -12,6 +12,7 @@
*/
#include "tclInt.h"
+#include <assert.h>
/*
* Prototypes for functions defined later in this file:
@@ -46,6 +47,27 @@ const Tcl_ObjType tclListType = {
SetListFromAny /* setFromAnyProc */
};
+/* Macros to manipulate the List internal rep */
+
+#define ListSetIntRep(objPtr, listRepPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (listRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ (listRepPtr)->refCount++; \
+ Tcl_StoreIntRep((objPtr), &tclListType, &ir); \
+ } while (0)
+
+#define ListGetIntRep(objPtr, listRepPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((objPtr), &tclListType); \
+ (listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
+#define ListResetIntRep(objPtr, listRepPtr) \
+ TclFetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr)
+
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif
@@ -55,22 +77,20 @@ const Tcl_ObjType tclListType = {
*
* NewListIntRep --
*
- * 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
+ * Creates a list internal rep 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. Flag value "p" indicates
* how to behave on failure.
*
- * Value
- *
- * 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.
- *
- * Effect
+ * Results:
+ * A new List struct with refCount 0 is returned. If some failure
+ * prevents this then if p=0, NULL is returned and otherwise the
+ * routine panics.
*
- * The refCount of each value 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.
*
*----------------------------------------------------------------------
*/
@@ -102,7 +122,7 @@ NewListIntRep(
return NULL;
}
- listRepPtr = attemptckalloc(LIST_SIZE(objc));
+ listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc));
if (listRepPtr == NULL) {
if (p) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
@@ -134,9 +154,21 @@ NewListIntRep(
/*
*----------------------------------------------------------------------
*
- * AttemptNewList --
+ * AttemptNewList --
*
- * Like NewListIntRep, but additionally sets an error message on failure.
+ * Creates a list internal rep 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.
+ *
+ * Results:
+ * A new List struct with refCount 0 is returned. If some failure
+ * prevents this then NULL is returned, and an error message is left
+ * in the interp result, unless interp is NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -169,20 +201,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.
- *
- * Value
+ * 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.
*
- * 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.
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewListObj.
*
- * Effect
+ * 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.
*
- * 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.
*
*----------------------------------------------------------------------
*/
@@ -233,14 +268,28 @@ Tcl_NewListObj(
/*
*----------------------------------------------------------------------
*
- * 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.
*
*----------------------------------------------------------------------
*/
@@ -287,10 +336,8 @@ Tcl_Obj *
Tcl_DbNewListObj(
int 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);
}
@@ -301,8 +348,19 @@ Tcl_DbNewListObj(
*
* 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.
*
*----------------------------------------------------------------------
*/
@@ -336,8 +394,7 @@ Tcl_SetListObj(
listRepPtr = NewListIntRep(objc, objv, 1);
ListSetIntRep(objPtr, listRepPtr);
} else {
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
+ Tcl_InitStringRep(objPtr, NULL, 0);
}
}
@@ -346,20 +403,18 @@ Tcl_SetListObj(
*
* TclListObjCopy --
*
- * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This
- * provides for the C level a counterpart of the [lrange $list 0 end]
- * command, while using internals details to be as efficient as possible.
- *
- * Value
+ * 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.
*
- * 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.
*
*----------------------------------------------------------------------
*/
@@ -371,8 +426,10 @@ TclListObjCopy(
* to be returned. */
{
Tcl_Obj *copyPtr;
+ List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
+ ListGetIntRep(listPtr, listRepPtr);
+ if (NULL == listRepPtr) {
if (SetListFromAny(interp, listPtr) != TCL_OK) {
return NULL;
}
@@ -387,32 +444,110 @@ TclListObjCopy(
/*
*----------------------------------------------------------------------
*
- * Tcl_ListObjGetElements --
+ * TclListObjRange --
*
- * Retreive the elements in a list 'Tcl_Obj'.
+ * Makes a slice of a list value.
+ * *listPtr 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.
*
- * 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_Obj *listPtr, /* List object to take a range from. */
+ int fromIdx, /* Index of first element to include. */
+ int toIdx) /* Index of last element to include. */
+{
+ Tcl_Obj **elemPtrs;
+ int listLen, i, newLen;
+ List *listRepPtr;
+
+ TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (toIdx >= listLen) {
+ toIdx = listLen-1;
+ }
+ if (fromIdx > toIdx) {
+ return Tcl_NewObj();
+ }
+
+ newLen = toIdx - fromIdx + 1;
+
+ if (Tcl_IsShared(listPtr) ||
+ ((ListRepPtr(listPtr)->refCount > 1))) {
+ return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]);
+ }
+
+ /*
+ * In-place is possible.
+ */
+
+ /*
+ * Even if nothing below cause any changes, we still want the
+ * string-canonizing effect of [lrange 0 end].
+ */
+
+ TclInvalidateStringRep(listPtr);
+
+ /*
+ * Delete elements that should not be included.
+ */
+
+ for (i = 0; i < fromIdx; i++) {
+ TclDecrRefCount(elemPtrs[i]);
+ }
+ for (i = toIdx + 1; i < listLen; i++) {
+ TclDecrRefCount(elemPtrs[i]);
+ }
+
+ if (fromIdx > 0) {
+ memmove(elemPtrs, &elemPtrs[fromIdx],
+ (size_t) newLen * sizeof(Tcl_Obj*));
+ }
+
+ listRepPtr = ListRepPtr(listPtr);
+ listRepPtr->elemCount = newLen;
+
+ return listPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * 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.
*
*----------------------------------------------------------------------
*/
@@ -420,19 +555,22 @@ TclListObjCopy(
int
Tcl_ListObjGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- register Tcl_Obj *listPtr, /* List object for which an element array is
+ Tcl_Obj *listPtr, /* List object for which an element array is
* to be returned. */
int *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. */
{
- register List *listRepPtr;
+ List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListGetIntRep(listPtr, listRepPtr);
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listRepPtr == NULL) {
+ int result, length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
*objcPtr = 0;
*objvPtr = NULL;
return TCL_OK;
@@ -441,8 +579,8 @@ Tcl_ListObjGetElements(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
*objcPtr = listRepPtr->elemCount;
*objvPtr = &listRepPtr->elements;
return TCL_OK;
@@ -453,27 +591,20 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * Appends the elements of elemListPtr to those of listPtr.
+ * This function appends the elements in the list value referenced by
+ * elemListPtr to the list value referenced by listPtr.
*
- * Value
+ * Results:
+ * The return value is normally TCL_OK. If listPtr or elemListPtr 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.
*
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' or 'elemListPtr' are not valid lists. 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 elemListPtr are incremented
+ * since the list now refers to them. listPtr and elemListPtr are
+ * converted, if necessary, to list objects. Also, appending the new
+ * elements may cause listObj's array of element pointers to grow.
+ * listPtr's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
@@ -481,7 +612,7 @@ Tcl_ListObjGetElements(
int
Tcl_ListObjAppendList(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- register Tcl_Obj *listPtr, /* List object to append elements to. */
+ Tcl_Obj *listPtr, /* List object to append elements to. */
Tcl_Obj *elemListPtr) /* List obj with elements to append. */
{
int objc;
@@ -512,27 +643,24 @@ Tcl_ListObjAppendList(
*
* Tcl_ListObjAppendElement --
*
- * Like 'Tcl_ListObjAppendList', but Appends a single value to a list.
- *
- * Value
- *
- * TCL_OK
- *
- * 'objPtr' is appended to the elements of 'listPtr'.
- *
- * TCL_ERROR
- *
- * listPtr does not refer to a list object and the object can not be
- * converted to one. An error message will be left in the
- * interpreter's result if interp is not NULL.
- *
- * Effect
- *
- * If 'listPtr' is not already of type 'tclListType', it is converted.
- * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'.
- * Appending the new element may cause the the array of element pointers
- * in 'listObj' to grow. Any preexisting string representation of
- * 'listPtr' is invalidated.
+ * This function is a special purpose version of Tcl_ListObjAppendList:
+ * it appends a single object referenced by objPtr to the list object
+ * referenced by listPtr. If listPtr is not already a list object, an
+ * attempt will be made to convert it to one.
+ *
+ * Results:
+ * The return value is normally TCL_OK; in this case objPtr is added to
+ * the end of listPtr's 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 ref count of objPtr is incremented since the list now refers to
+ * it. listPtr will be converted, if necessary, to a list object. Also,
+ * appending the new element may cause listObj's array of element
+ * pointers to grow. listPtr's old string representation, if any, is
+ * invalidated.
*
*----------------------------------------------------------------------
*/
@@ -543,16 +671,19 @@ Tcl_ListObjAppendElement(
Tcl_Obj *listPtr, /* List object to append objPtr to. */
Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
{
- register List *listRepPtr, *newPtr = NULL;
+ 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) {
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
}
@@ -560,9 +691,9 @@ Tcl_ListObjAppendElement(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
numElems = listRepPtr->elemCount;
numRequired = numElems + 1 ;
needGrow = (numRequired > listRepPtr->maxElemCount);
@@ -585,18 +716,18 @@ Tcl_ListObjAppendElement(
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
@@ -653,12 +784,16 @@ Tcl_ListObjAppendElement(
* Old intrep to be freed, re-use refCounts.
*/
- memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
+ memcpy(dst, src, numElems * sizeof(Tcl_Obj *));
ckfree(listRepPtr);
}
listRepPtr = newPtr;
}
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ ListResetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount++;
+ TclFreeIntRep(listPtr);
+ ListSetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount--;
/*
* Add objPtr to the end of listPtr's array of element pointers. Increment
@@ -683,27 +818,23 @@ Tcl_ListObjAppendElement(
*
* Tcl_ListObjIndex --
*
- * Retrieve a pointer to the element of 'listPtr' at 'index'. The index
- * of the first element is 0.
- *
- * Value
+ * This function returns a pointer to the index'th object from the list
+ * referenced by listPtr. The first element has index 0. If index is
+ * negative or greater than or equal to the number of elements in the
+ * list, a NULL is returned. If listPtr is not a list object, an attempt
+ * will be made to convert it to a list.
*
- * TCL_OK
+ * Results:
+ * The return value is normally TCL_OK; in this case objPtrPtr is set to
+ * the Tcl_Obj pointer for the index'th list element or NULL if index is
+ * out of range. This object should be treated as readonly and its ref
+ * count is _not_ incremented; the caller must do that if it holds on to
+ * the reference. If listPtr does not refer to a list and can't be
+ * converted to one, TCL_ERROR is returned and an error message is left
+ * in the interpreter's result if interp is not NULL.
*
- * A pointer to the element at 'index' is stored in 'objPtrPtr'. If
- * 'index' is out of range, NULL is stored in 'objPtrPtr'. This
- * object should be treated as readonly and its 'refCount' is _not_
- * incremented. The caller must do that if it holds on to the
- * reference.
- *
- * TCL_ERROR
- *
- * 'listPtr' is not a valid list. An an error message is left in the
- * interpreter's result if 'interp' is not NULL.
- *
- * Effect
- *
- * If 'listPtr' is not already of type 'tclListType', it is converted.
+ * Side effects:
+ * listPtr will be converted, if necessary, to a list object.
*
*----------------------------------------------------------------------
*/
@@ -711,16 +842,18 @@ Tcl_ListObjAppendElement(
int
Tcl_ListObjIndex(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- register Tcl_Obj *listPtr, /* List object to index into. */
- register int index, /* Index of element to return. */
+ 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. */
{
- register List *listRepPtr;
+ List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
- if (listPtr->bytes == tclEmptyStringRep) {
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
*objPtrPtr = NULL;
return TCL_OK;
}
@@ -728,9 +861,9 @@ Tcl_ListObjIndex(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
if ((index < 0) || (index >= listRepPtr->elemCount)) {
*objPtrPtr = NULL;
} else {
@@ -745,20 +878,19 @@ Tcl_ListObjIndex(
*
* Tcl_ListObjLength --
*
- * Retrieve the number of elements in a list.
- *
- * Value
- *
- * TCL_OK
+ * 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.
*
- * A count of list elements is stored at the address provided by
- * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is
- * converted.
+ * Results:
+ * The return value is normally TCL_OK; in this case *intPtr will be set
+ * to the integer count of list elements. If listPtr does not refer to a
+ * list object and the object can not be converted to one, TCL_ERROR is
+ * returned and an error message will be left in the interpreter's result
+ * if interp is not NULL.
*
- * TCL_ERROR
- *
- * '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.
*
*----------------------------------------------------------------------
*/
@@ -766,15 +898,17 @@ Tcl_ListObjIndex(
int
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- register Tcl_Obj *listPtr, /* List object whose #elements to return. */
- register int *intPtr) /* The resulting int is stored here. */
+ Tcl_Obj *listPtr, /* List object whose #elements to return. */
+ int *intPtr) /* The resulting int is stored here. */
{
- register List *listRepPtr;
+ List *listRepPtr;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
- if (listPtr->bytes == tclEmptyStringRep) {
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
*intPtr = 0;
return TCL_OK;
}
@@ -782,9 +916,9 @@ Tcl_ListObjLength(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
*intPtr = listRepPtr->elemCount;
return TCL_OK;
}
@@ -794,36 +928,35 @@ 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
+ * listPtr 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. listPtr is converted, if necessary,
+ * to a list object. listPtr's old string representation, if any, is
+ * freed.
*
*----------------------------------------------------------------------
*/
@@ -839,15 +972,20 @@ Tcl_ListObjReplace(
* insert. */
{
List *listRepPtr;
- register Tcl_Obj **elemPtrs;
+ Tcl_Obj **elemPtrs;
int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- if (listPtr->typePtr != &tclListType) {
- if (listPtr->bytes == tclEmptyStringRep) {
- if (!objc) {
+
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
+ if (objc == 0) {
return TCL_OK;
}
Tcl_SetListObj(listPtr, objc, NULL);
@@ -858,6 +996,7 @@ Tcl_ListObjReplace(
return result;
}
}
+ ListGetIntRep(listPtr, listRepPtr);
}
/*
@@ -868,7 +1007,6 @@ Tcl_ListObjReplace(
* Resist any temptation to optimize this case.
*/
- listRepPtr = ListRepPtr(listPtr);
elemPtrs = &listRepPtr->elements;
numElems = listRepPtr->elemCount;
@@ -907,22 +1045,22 @@ Tcl_ListObjReplace(
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
- newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ ListResetIntRep(listPtr, listRepPtr);
elemPtrs = &listRepPtr->elements;
listRepPtr->maxElemCount = attempt;
needGrow = numRequired > listRepPtr->maxElemCount;
@@ -965,7 +1103,7 @@ Tcl_ListObjReplace(
Tcl_Obj **oldPtrs = elemPtrs;
int newMax;
- if (needGrow){
+ if (needGrow) {
newMax = 2 * numRequired;
} else {
newMax = listRepPtr->maxElemCount;
@@ -995,7 +1133,7 @@ Tcl_ListObjReplace(
}
}
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ ListResetIntRep(listPtr, listRepPtr);
listRepPtr->refCount++;
elemPtrs = &listRepPtr->elements;
@@ -1024,7 +1162,7 @@ Tcl_ListObjReplace(
*/
if (first > 0) {
- memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *));
+ memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *));
}
/*
@@ -1068,10 +1206,15 @@ Tcl_ListObjReplace(
listRepPtr->elemCount = numRequired;
/*
- * Invalidate and free any old string representation since it no longer
- * reflects the list's internal representation.
+ * Invalidate and free any old representations that may not agree
+ * with the revised list's internal representation.
*/
+ listRepPtr->refCount++;
+ TclFreeIntRep(listPtr);
+ ListSetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount--;
+
TclInvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1081,19 +1224,22 @@ Tcl_ListObjReplace(
*
* TclLindexList --
*
- * Implements the 'lindex' command when objc==3.
+ * This procedure handles the 'lindex' command when objc==3.
*
- * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures
- * the argument format into required form while taking care to manage
- * shimmering so as to tend to keep the most useful intreps
- * and/or avoid the most expensive conversions.
+ * Results:
+ * Returns a pointer to the object extracted, or NULL if an error
+ * occurred. The returned object already includes one reference count for
+ * the pointer returned.
*
- * Value
+ * Side effects:
+ * None.
*
- * A pointer to the specified element, with its 'refCount' incremented, or
- * NULL if an error occurred.
- *
- * Notes
+ * Notes:
+ * This procedure is implemented entirely as a wrapper around
+ * TclLindexFlat. All it does is reconfigure the argument format into the
+ * form required by TclLindexFlat, while taking care to manage shimmering
+ * in such a way that we tend to keep the most useful intreps and/or
+ * avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
@@ -1107,6 +1253,7 @@ TclLindexList(
int index; /* Index into the list. */
Tcl_Obj *indexListCopy;
+ List *listRepPtr;
/*
* Determine whether argPtr designates a list or a single index. We have
@@ -1114,8 +1261,9 @@ TclLindexList(
* shimmering; see TIP#22 and TIP#33 for the details.
*/
- if (argPtr->typePtr != &tclListType
- && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) {
+ ListGetIntRep(argPtr, listRepPtr);
+ if ((listRepPtr == NULL)
+ && TclGetIntForIndexM(NULL , argPtr, INT_MAX - 1, &index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
@@ -1145,13 +1293,12 @@ TclLindexList(
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
- {
- int indexCount = -1; /* Size of the array of list indices. */
- Tcl_Obj **indices = NULL; /* Array of list indices. */
+ ListGetIntRep(indexListCopy, listRepPtr);
- TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
- listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
- }
+ assert(listRepPtr != NULL);
+
+ listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
+ &listRepPtr->elements);
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
@@ -1159,20 +1306,25 @@ TclLindexList(
/*
*----------------------------------------------------------------------
*
- * 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);
*
*----------------------------------------------------------------------
*/
@@ -1221,7 +1373,7 @@ TclLindexFlat(
*/
while (++i < indexCount) {
- if (TclGetIntForIndexM(interp, indexArray[i], -1, &index)
+ if (TclGetIntForIndexM(interp, indexArray[i], INT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
@@ -1248,16 +1400,24 @@ 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 intreps and/or
+ * avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
@@ -1267,13 +1427,14 @@ 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 *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int 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 *indexListCopy;
+ List *listRepPtr;
/*
* Determine whether the index arg designates a list or a single index.
@@ -1281,8 +1442,9 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- if (indexArgPtr->typePtr != &tclListType
- && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) {
+ ListGetIntRep(indexArgPtr, listRepPtr);
+ if (listRepPtr == NULL
+ && TclGetIntForIndexM(NULL, indexArgPtr, INT_MAX - 1, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
*/
@@ -1318,40 +1480,38 @@ 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
+ * 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.)
+ *
+ * Surgery is performed on the unshared list value to produce the result.
+ * TclLsetFlat maintains a linked list of Tcl_Obj's whose string
* representations must be spoilt by threading via 'ptr2' of the
- * two-pointer internal representation. On entry to 'TclLsetFlat', 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.
*
@@ -1365,18 +1525,22 @@ TclLsetFlat(
int indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int index, result, len;
Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
+ Tcl_ObjIntRep *irPtr;
/*
* 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 valuePtr just in case.
*/
if (indexCount == 0) {
- Tcl_IncrRefCount(valuePtr);
+ if (valuePtr != NULL) {
+ Tcl_IncrRefCount(valuePtr);
+ }
return valuePtr;
}
@@ -1436,13 +1600,14 @@ TclLsetFlat(
}
indexArray++;
- if (index < 0 || index > elemCount) {
+ if (index < 0 || index > elemCount
+ || (valuePtr == 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_SetObjResult(interp, Tcl_ObjPrintf(
+ "index \"%s\" out of range", Tcl_GetString(indexArray[-1])));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
+ "OUTOFRANGE", NULL);
}
result = TCL_ERROR;
break;
@@ -1499,7 +1664,8 @@ TclLsetFlat(
* them at that time.
*/
- parentList->internalRep.twoPtrValue.ptr2 = chainPtr;
+ irPtr = TclFetchIntRep(parentList, &tclListType);
+ irPtr->twoPtrValue.ptr2 = chainPtr;
chainPtr = parentList;
}
} while (indexCount > 0);
@@ -1513,22 +1679,32 @@ TclLsetFlat(
while (chainPtr) {
Tcl_Obj *objPtr = chainPtr;
+ List *listRepPtr;
+
+ /*
+ * Clear away our intrep surgery mess.
+ */
+
+ irPtr = TclFetchIntRep(objPtr, &tclListType);
+ listRepPtr = (List *)irPtr->twoPtrValue.ptr1;
+ chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
if (result == TCL_OK) {
+
/*
* We're going to store valuePtr, so spoil string reps of all
* containing lists.
*/
+ listRepPtr->refCount++;
+ TclFreeIntRep(objPtr);
+ ListSetIntRep(objPtr, listRepPtr);
+ listRepPtr->refCount--;
+
TclInvalidateStringRep(objPtr);
+ } else {
+ irPtr->twoPtrValue.ptr2 = NULL;
}
-
- /*
- * Clear away our intrep surgery mess.
- */
-
- chainPtr = objPtr->internalRep.twoPtrValue.ptr2;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
if (result != TCL_OK) {
@@ -1551,12 +1727,14 @@ TclLsetFlat(
len = -1;
TclListObjLength(NULL, subListPtr, &len);
- if (index == len) {
+ if (valuePtr == NULL) {
+ Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL);
+ } else if (index == len) {
Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
} else {
TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ TclInvalidateStringRep(subListPtr);
}
- TclInvalidateStringRep(subListPtr);
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
}
@@ -1566,38 +1744,26 @@ TclLsetFlat(
*
* TclListObjSetElement --
*
- * Set a single element of a list to a specified value.
- *
- * It is the caller's responsibility to invalidate the string
- * representation of the 'listPtr'.
- *
- * Value
- *
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' does not refer to a list object and cannot be converted
- * to one. An error message will be left in the interpreter result if
- * interp is not NULL.
+ * Set a single element of a list to a specified value
*
- * TCL_ERROR
+ * Results:
+ * The return value is normally TCL_OK. If listPtr 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 listPtr, TCL_ERROR is returned and an error
+ * message is left in the interpreter result.
*
- * 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.
+ * Side effects:
+ * Tcl_Panic if listPtr 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 valuePtr, and increments the
+ * ref count of the replacement object.
*
+ * It is the caller's responsibility to invalidate the string
+ * representation of the object.
*
*----------------------------------------------------------------------
*/
@@ -1624,15 +1790,18 @@ TclListObjSetElement(
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
- if (listPtr->typePtr != &tclListType) {
- int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ ListGetIntRep(listPtr, listRepPtr);
+ if (listRepPtr == NULL) {
+ int result, length;
+
+ (void) Tcl_GetStringFromObj(listPtr, &length);
+ if (length == 0) {
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;
}
@@ -1640,9 +1809,9 @@ TclListObjSetElement(
if (result != TCL_OK) {
return result;
}
+ ListGetIntRep(listPtr, listRepPtr);
}
- listRepPtr = ListRepPtr(listPtr);
elemCount = listRepPtr->elemCount;
/*
@@ -1651,10 +1820,10 @@ TclListObjSetElement(
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;
}
@@ -1685,7 +1854,8 @@ TclListObjSetElement(
listRepPtr->refCount--;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;
+ listRepPtr = newPtr;
+ ListResetIntRep(listPtr, listRepPtr);
}
elemPtrs = &listRepPtr->elements;
@@ -1707,6 +1877,18 @@ TclListObjSetElement(
elemPtrs[index] = valuePtr;
+ /*
+ * Invalidate outdated intreps.
+ */
+
+ ListGetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount++;
+ TclFreeIntRep(listPtr);
+ ListSetIntRep(listPtr, listRepPtr);
+ listRepPtr->refCount--;
+
+ TclInvalidateStringRep(listPtr);
+
return TCL_OK;
}
@@ -1715,14 +1897,15 @@ 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.
*
*----------------------------------------------------------------------
*/
@@ -1731,7 +1914,10 @@ static void
FreeListInternalRep(
Tcl_Obj *listPtr) /* List object with internal rep to free. */
{
- List *listRepPtr = ListRepPtr(listPtr);
+ List *listRepPtr;
+
+ ListGetIntRep(listPtr, listRepPtr);
+ assert(listRepPtr != NULL);
if (listRepPtr->refCount-- <= 1) {
Tcl_Obj **elemPtrs = &listRepPtr->elements;
@@ -1742,8 +1928,6 @@ FreeListInternalRep(
}
ckfree(listRepPtr);
}
-
- listPtr->typePtr = NULL;
}
/*
@@ -1751,12 +1935,14 @@ 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.
*
*----------------------------------------------------------------------
*/
@@ -1766,8 +1952,10 @@ DupListInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- List *listRepPtr = ListRepPtr(srcPtr);
+ List *listRepPtr;
+ ListGetIntRep(srcPtr, listRepPtr);
+ assert(listRepPtr != NULL);
ListSetIntRep(copyPtr, listRepPtr);
}
@@ -1776,20 +1964,16 @@ DupListInternalRep(
*
* SetListFromAny --
*
- * Convert any object to a list.
+ * Attempt to generate a list internal form for the Tcl object "objPtr".
*
- * Value
- *
- * 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.
*
*----------------------------------------------------------------------
*/
@@ -1810,7 +1994,7 @@ SetListFromAny(
* describe duplicate keys).
*/
- if (objPtr->typePtr == &tclDictType && !objPtr->bytes) {
+ if (!TclHasStringRep(objPtr) && TclHasIntRep(objPtr, &tclDictType)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done, size;
@@ -1868,28 +2052,37 @@ SetListFromAny(
while (nextElem < limit) {
const char *elemStart;
+ char *check;
int elemSize, literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
+ fail:
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
- ckfree((char *) listRepPtr);
+ ckfree(listRepPtr);
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) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "cannot construct list, out of memory", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ goto fail;
+ }
+ if (!literal) {
+ Tcl_InitStringRep(*elemPtrs, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, check));
}
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
@@ -1899,12 +2092,11 @@ SetListFromAny(
}
/*
- * 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.
*/
- TclFreeIntRep(objPtr);
ListSetIntRep(objPtr, listRepPtr);
return TCL_OK;
}
@@ -1914,16 +2106,18 @@ SetListFromAny(
*
* UpdateStringOfList --
*
- * Update the string representation for a list object.
- *
- * Any previously-exising string representation is not invalidated, so
- * storage is lost if this has not been taken care of.
+ * Update the string representation for a list object. Note: This
+ * function does not invalidate an existing old string rep so storage
+ * will be lost if this has not already been done.
*
- * Effect
+ * Results:
+ * None.
*
- * The string representation of 'listPtr' is set to the resulting string.
- * This string will be empty if the list has no elements. It is assumed
- * that the list internal representation is not NULL.
+ * 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.
*
*----------------------------------------------------------------------
*/
@@ -1934,12 +2128,17 @@ UpdateStringOfList(
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- List *listRepPtr = ListRepPtr(listPtr);
- int numElems = listRepPtr->elemCount;
- int i, length, bytesNeeded = 0;
- const char *elem;
+ int numElems, i, length, bytesNeeded = 0;
+ const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
+ List *listRepPtr;
+
+ ListGetIntRep(listPtr, listRepPtr);
+
+ assert(listRepPtr != NULL);
+
+ numElems = listRepPtr->elemCount;
/*
* Mark the list as being canonical; although it will now have a string
@@ -1954,8 +2153,7 @@ UpdateStringOfList(
*/
if (numElems == 0) {
- listPtr->bytes = tclEmptyStringRep;
- listPtr->length = 0;
+ Tcl_InitStringRep(listPtr, NULL, 0);
return;
}
@@ -1970,7 +2168,7 @@ UpdateStringOfList(
* We know numElems <= LIST_MAX, so this is safe.
*/
- flagPtr = ckalloc(numElems);
+ flagPtr = (char *)ckalloc(numElems);
}
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
@@ -1984,39 +2182,23 @@ UpdateStringOfList(
if (bytesNeeded > INT_MAX - numElems + 1) {
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(listPtr, 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(listPtr, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
ckfree(flagPtr);
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 55473c1..22eff3c 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -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,11 +211,11 @@ TclCreateLiteral(
*/
int objLength;
- char *objBytes = TclGetStringFromObj(objPtr, &objLength);
+ const char *objBytes = TclGetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
- && (memcmp(objBytes, bytes, (unsigned) length) == 0)))) {
+ && (memcmp(objBytes, bytes, length) == 0)))) {
/*
* A literal was found: return it
*/
@@ -227,7 +229,9 @@ TclCreateLiteral(
if (flags & LITERAL_ON_HEAP) {
ckfree(bytes);
}
- globalPtr->refCount++;
+ if (globalPtr->refCount != (unsigned) -1) {
+ 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 accross
* 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) {
@@ -418,7 +429,7 @@ TclRegisterLiteral(
objPtr = localPtr->objPtr;
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
- && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
+ && (memcmp(objPtr->bytes, bytes, length) == 0)))) {
if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
@@ -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 = (unsigned) -1; /* 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 != (unsigned)-1) && (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;
@@ -1048,11 +1060,11 @@ 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) {
+ if (TclHasIntRep(literalObjPtr, &tclCmdNameType)) {
TclFreeIntRep(literalObjPtr);
}
/* Balance the refcount effects of TclCreateLiteral() above */
@@ -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++) {
- sprintf(p, "number of buckets with %d entries: %d\n",
+ sprintf(p, "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 != (unsigned)-1) {
+ 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 dfa657e..738f65b 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -115,7 +115,7 @@ static void LoadCleanupProc(ClientData clientData,
int
Tcl_LoadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -271,7 +271,7 @@ Tcl_LoadObjCmd(
*/
if (pkgPtr != NULL) {
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
@@ -401,12 +401,12 @@ Tcl_LoadObjCmd(
* Create a new record to describe this package.
*/
- pkgPtr = ckalloc(sizeof(LoadedPackage));
+ pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage));
len = strlen(fullFileName) + 1;
- pkgPtr->fileName = ckalloc(len);
+ pkgPtr->fileName = (char *)ckalloc(len);
memcpy(pkgPtr->fileName, fullFileName, len);
- len = (unsigned) Tcl_DStringLength(&pkgName) + 1;
- pkgPtr->packageName = ckalloc(len);
+ len = Tcl_DStringLength(&pkgName) + 1;
+ pkgPtr->packageName = (char *)ckalloc(len);
memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len);
pkgPtr->loadHandle = loadHandle;
pkgPtr->initProc = initProc;
@@ -470,6 +470,19 @@ 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;
}
@@ -494,8 +507,8 @@ Tcl_LoadObjCmd(
* static packages at the head of the linked list!
*/
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
- ipPtr = ckalloc(sizeof(InterpPackage));
+ ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
@@ -529,7 +542,7 @@ Tcl_LoadObjCmd(
int
Tcl_UnloadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -707,7 +720,7 @@ Tcl_UnloadObjCmd(
code = TCL_ERROR;
if (pkgPtr != NULL) {
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
@@ -862,7 +875,7 @@ Tcl_UnloadObjCmd(
* Remove this library from the interpreter's library cache.
*/
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = ipFirstPtr;
if (ipPtr->pkgPtr == defaultPtr) {
ipFirstPtr = ipFirstPtr->nextPtr;
@@ -969,10 +982,10 @@ Tcl_StaticPackage(
*/
if (pkgPtr == NULL) {
- pkgPtr = ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = ckalloc(1);
+ pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage));
+ pkgPtr->fileName = (char *)ckalloc(1);
pkgPtr->fileName[0] = 0;
- pkgPtr->packageName = ckalloc(strlen(pkgName) + 1);
+ pkgPtr->packageName = (char *)ckalloc(strlen(pkgName) + 1);
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
@@ -990,7 +1003,7 @@ Tcl_StaticPackage(
* it's already loaded.
*/
- ipFirstPtr = Tcl_GetAssocData(interp, "tclLoad", NULL);
+ ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
return;
@@ -998,11 +1011,11 @@ Tcl_StaticPackage(
}
/*
- * Package isn't loade in the current interp yet. Mark it as now being
+ * Package isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
- ipPtr = ckalloc(sizeof(InterpPackage));
+ ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
@@ -1012,10 +1025,10 @@ Tcl_StaticPackage(
/*
*----------------------------------------------------------------------
*
- * TclGetLoadedPackages --
+ * TclGetLoadedPackages, TclGetLoadedPackagesEx --
*
* This function returns information about all of the files that are
- * loaded (either in a particular intepreter, or for all interpreters).
+ * loaded (either in a particular interpreter, or for all interpreters).
*
* Results:
* The return value is a standard Tcl completion code. If successful, a
@@ -1039,16 +1052,27 @@ TclGetLoadedPackages(
* otherwise, just return info about this
* interpreter. */
{
+ return TclGetLoadedPackagesEx(interp, targetName, NULL);
+}
+
+int
+TclGetLoadedPackagesEx(
+ 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. */
+ const char *packageName) /* Package name or NULL. If NULL, return info
+ * for all packages.
+ */
+{
Tcl_Interp *target;
LoadedPackage *pkgPtr;
InterpPackage *ipPtr;
Tcl_Obj *resultObj, *pkgDesc[2];
if (targetName == NULL) {
- /*
- * Return information about all of the available packages.
- */
-
resultObj = Tcl_NewObj();
Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
@@ -1063,16 +1087,38 @@ TclGetLoadedPackages(
return TCL_OK;
}
+ target = Tcl_GetSlave(interp, targetName);
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
+ ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
+
+ /*
+ * Return information about all of the available packages.
+ */
+ if (packageName) {
+ resultObj = NULL;
+
+ for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ pkgPtr = ipPtr->pkgPtr;
+
+ if (!strcmp(packageName, pkgPtr->packageName)) {
+ resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1);
+ break;
+ }
+ }
+
+ if (resultObj) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ return TCL_OK;
+ }
+
/*
* Return information about only the packages that are loaded in a given
* interpreter.
*/
- target = Tcl_GetSlave(interp, targetName);
- if (target == NULL) {
- return TCL_ERROR;
- }
- ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
resultObj = Tcl_NewObj();
for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
pkgPtr = ipPtr->pkgPtr;
@@ -1106,11 +1152,11 @@ static void
LoadCleanupProc(
ClientData clientData, /* Pointer to first InterpPackage structure
* for interp. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
+ TCL_UNUSED(Tcl_Interp *))
{
InterpPackage *ipPtr, *nextPtr;
- ipPtr = clientData;
+ ipPtr = (InterpPackage *)clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
ckfree(ipPtr);
diff --git a/generic/tclMain.c b/generic/tclMain.c
index cef4543..4f44685 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -50,7 +50,8 @@ 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);
#endif
@@ -95,7 +96,7 @@ typedef enum {
PROMPT_CONTINUE /* Print prompt for command continuation */
} PromptType;
-typedef struct InteractiveState {
+typedef struct {
Tcl_Channel input; /* The standard input channel from which lines
* are read. */
int tty; /* Non-zero means standard input is a
@@ -229,7 +230,7 @@ Tcl_SourceRCFile(
const char *fileName;
Tcl_Channel chan;
- fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
+ fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
@@ -266,7 +267,7 @@ Tcl_SourceRCFile(
/*----------------------------------------------------------------------
*
- * Tcl_Main, Tcl_MainEx --
+ * Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -445,7 +446,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();
@@ -515,7 +516,7 @@ Tcl_MainEx(
* error messages troubles deeper in, so lop it back off.
*/
- Tcl_GetStringFromObj(is.commandPtr, &length);
+ TclGetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
@@ -532,7 +533,7 @@ Tcl_MainEx(
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
- Tcl_GetStringFromObj(resultPtr, &length);
+ TclGetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
@@ -617,21 +618,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)
@@ -745,14 +731,13 @@ TclFullFinalizationRequested(void)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
- int mask) /* Not used. */
+ TCL_UNUSED(int) /*mask*/)
{
int code, length;
- InteractiveState *isPtr = clientData;
+ InteractiveState *isPtr = (InteractiveState *)clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
@@ -791,7 +776,7 @@ StdinProc(
goto prompt;
}
isPtr->prompt = PROMPT_START;
- Tcl_GetStringFromObj(commandPtr, &length);
+ TclGetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
/*
@@ -822,7 +807,7 @@ StdinProc(
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
- Tcl_GetStringFromObj(resultPtr, &length);
+ TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (chan != NULL)) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
@@ -924,7 +909,7 @@ static void
FreeMainInterp(
ClientData clientData)
{
- Tcl_Interp *interp = clientData;
+ Tcl_Interp *interp = (Tcl_Interp *)clientData;
/*if (TclInExit()) return;*/
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index cf4ecc4..26dca62 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -25,14 +25,15 @@
#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
* limited to a single interpreter.
*/
-typedef struct ThreadSpecificData {
- long numNsCreated; /* Count of the number of namespaces created
+typedef struct {
+ 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
@@ -89,51 +90,29 @@ static char * EstablishErrorInfoTraces(ClientData clientData,
static void FreeNsNameInternalRep(Tcl_Obj *objPtr);
static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
-static int InvokeImportedCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int InvokeImportedNRCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceChildrenCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceCurrentCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NRNamespaceEvalCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc NamespaceChildrenCmd;
+static Tcl_ObjCmdProc NamespaceCodeCmd;
+static Tcl_ObjCmdProc NamespaceCurrentCmd;
+static Tcl_ObjCmdProc NamespaceDeleteCmd;
+static Tcl_ObjCmdProc NamespaceEvalCmd;
+static Tcl_ObjCmdProc NRNamespaceEvalCmd;
+static Tcl_ObjCmdProc NamespaceExistsCmd;
+static Tcl_ObjCmdProc NamespaceExportCmd;
+static Tcl_ObjCmdProc NamespaceForgetCmd;
static void NamespaceFree(Namespace *nsPtr);
-static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceInscopeCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NRNamespaceInscopeCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceQualifiersCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int NamespaceUnknownCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc NamespaceImportCmd;
+static Tcl_ObjCmdProc NamespaceInscopeCmd;
+static Tcl_ObjCmdProc NRNamespaceInscopeCmd;
+static Tcl_ObjCmdProc NamespaceOriginCmd;
+static Tcl_ObjCmdProc NamespaceParentCmd;
+static Tcl_ObjCmdProc NamespacePathCmd;
+static Tcl_ObjCmdProc NamespaceQualifiersCmd;
+static Tcl_ObjCmdProc NamespaceTailCmd;
+static Tcl_ObjCmdProc NamespaceUpvarCmd;
+static Tcl_ObjCmdProc NamespaceUnknownCmd;
+static Tcl_ObjCmdProc NamespaceWhichCmd;
static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UnlinkNsPath(Namespace *nsPtr);
@@ -154,6 +133,22 @@ static const Tcl_ObjType nsNameType = {
SetNsNameFromAny /* setFromAnyProc */
};
+#define NsNameSetIntRep(objPtr, nnPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (nnPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (nnPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \
+ } while (0)
+
+#define NsNameGetIntRep(objPtr, nnPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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.
@@ -225,7 +220,7 @@ TclInitNamespaceSubsystem(void)
Tcl_Namespace *
Tcl_GetCurrentNamespace(
- register Tcl_Interp *interp)/* Interpreter whose current namespace is
+ Tcl_Interp *interp)/* Interpreter whose current namespace is
* being queried. */
{
return TclGetCurrentNamespace(interp);
@@ -249,7 +244,7 @@ Tcl_GetCurrentNamespace(
Tcl_Namespace *
Tcl_GetGlobalNamespace(
- register Tcl_Interp *interp)/* Interpreter whose global namespace should
+ Tcl_Interp *interp)/* Interpreter whose global namespace should
* be returned. */
{
return TclGetGlobalNamespace(interp);
@@ -301,8 +296,8 @@ Tcl_PushCallFrame(
* variables. */
{
Interp *iPtr = (Interp *) interp;
- register CallFrame *framePtr = (CallFrame *) callFramePtr;
- register Namespace *nsPtr;
+ CallFrame *framePtr = (CallFrame *) callFramePtr;
+ Namespace *nsPtr;
if (namespacePtr == NULL) {
nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
@@ -320,7 +315,6 @@ Tcl_PushCallFrame(
if (nsPtr->flags & NS_DEAD) {
Tcl_Panic("Trying to push call frame for dead namespace");
- /*NOTREACHED*/
}
}
@@ -378,8 +372,8 @@ void
Tcl_PopCallFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
- register Interp *iPtr = (Interp *) interp;
- register CallFrame *framePtr = iPtr->framePtr;
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->framePtr;
Namespace *nsPtr;
/*
@@ -402,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;
@@ -465,7 +459,7 @@ TclPushStackFrame(
* treated as references to namespace
* variables. */
{
- *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame));
+ *framePtrPtr = (Tcl_CallFrame *)TclStackAlloc(interp, sizeof(CallFrame));
return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
isProcCallFrame);
}
@@ -499,11 +493,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);
@@ -531,11 +525,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;
@@ -573,11 +567,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);
@@ -605,11 +599,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;
@@ -664,7 +658,7 @@ Tcl_CreateNamespace(
* function should be called. */
{
Interp *iPtr = (Interp *) interp;
- register Namespace *nsPtr, *ancestorPtr;
+ Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
const char *simpleName;
@@ -770,9 +764,9 @@ Tcl_CreateNamespace(
*/
doCreate:
- nsPtr = ckalloc(sizeof(Namespace));
+ nsPtr = (Namespace *)ckalloc(sizeof(Namespace));
nameLen = strlen(simpleName) + 1;
- nsPtr->name = ckalloc(nameLen);
+ nsPtr->name = (char *)ckalloc(nameLen);
memcpy(nsPtr->name, simpleName, nameLen);
nsPtr->fullName = NULL; /* Set below. */
nsPtr->clientData = clientData;
@@ -833,7 +827,7 @@ Tcl_CreateNamespace(
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
- register Tcl_DString *tempPtr = namePtr;
+ Tcl_DString *tempPtr = namePtr;
TclDStringAppendLiteral(buffPtr, "::");
Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
@@ -860,8 +854,8 @@ Tcl_CreateNamespace(
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
- nsPtr->fullName = ckalloc(nameLen + 1);
- memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1);
+ nsPtr->fullName = (char *)ckalloc(nameLen + 1);
+ memcpy(nsPtr->fullName, name, nameLen + 1);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
@@ -907,7 +901,7 @@ void
Tcl_DeleteNamespace(
Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
- register Namespace *nsPtr = (Namespace *) namespacePtr;
+ Namespace *nsPtr = (Namespace *) namespacePtr;
Interp *iPtr = (Interp *) nsPtr->interp;
Namespace *globalNsPtr = (Namespace *)
TclGetGlobalNamespace((Tcl_Interp *) iPtr);
@@ -952,7 +946,7 @@ Tcl_DeleteNamespace(
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (cmdPtr->nreProc == TclNRInterpCoroutine) {
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr);
@@ -1103,11 +1097,11 @@ TclNamespaceDeleted(
void
TclTeardownNamespace(
- register Namespace *nsPtr) /* Points to the namespace to be dismantled
+ Namespace *nsPtr) /* Points to the namespace to be dismantled
* and unlinked from its parent. */
{
Interp *iPtr = (Interp *) nsPtr->interp;
- register Tcl_HashEntry *entryPtr;
+ Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
int i;
@@ -1131,14 +1125,14 @@ TclTeardownNamespace(
while (nsPtr->cmdTable.numEntries > 0) {
int length = nsPtr->cmdTable.numEntries;
- Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr,
+ Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Command *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
- cmds[i] = Tcl_GetHashValue(entryPtr);
+ cmds[i] = (Command *)Tcl_GetHashValue(entryPtr);
cmds[i]->refCount++;
i++;
}
@@ -1203,14 +1197,14 @@ TclTeardownNamespace(
#ifndef BREAK_NAMESPACE_COMPAT
while (nsPtr->childTable.numEntries > 0) {
int length = nsPtr->childTable.numEntries;
- Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
+ 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] = Tcl_GetHashValue(entryPtr);
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
children[i]->refCount++;
i++;
}
@@ -1224,7 +1218,7 @@ TclTeardownNamespace(
if (nsPtr->childTablePtr != NULL) {
while (nsPtr->childTablePtr->numEntries > 0) {
int length = nsPtr->childTablePtr->numEntries;
- Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Namespace *) * length);
i = 0;
@@ -1296,7 +1290,7 @@ TclTeardownNamespace(
static void
NamespaceFree(
- register Namespace *nsPtr) /* Points to the namespace to free. */
+ Namespace *nsPtr) /* Points to the namespace to free. */
{
/*
* Most of the namespace's contents are freed when the namespace is
@@ -1330,8 +1324,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);
}
}
@@ -1445,7 +1438,7 @@ Tcl_Export(
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
- nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr,
+ nsPtr->exportArrayPtr = (char **)ckrealloc(nsPtr->exportArrayPtr,
sizeof(char *) * nsPtr->maxExportPatterns);
}
@@ -1454,8 +1447,8 @@ Tcl_Export(
*/
len = strlen(pattern);
- patternCpy = ckalloc(len + 1);
- memcpy(patternCpy, pattern, (unsigned) len + 1);
+ patternCpy = (char *)ckalloc(len + 1);
+ memcpy(patternCpy, pattern, len + 1);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
@@ -1572,7 +1565,7 @@ Tcl_Import(
{
Namespace *nsPtr, *importNsPtr, *dummyPtr;
const char *simplePattern;
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
@@ -1665,7 +1658,7 @@ Tcl_Import(
}
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
- char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
+ char *cmdName = (char *)Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern) &&
DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
@@ -1752,13 +1745,13 @@ DoImport(
* namespace would create a cycle of imported command references.
*/
- cmdPtr = Tcl_GetHashValue(hPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
- Command *overwrite = Tcl_GetHashValue(found);
+ Command *overwrite = (Command *)Tcl_GetHashValue(found);
Command *linkCmd = cmdPtr;
while (linkCmd->deleteProc == DeleteImportedCmd) {
- dataPtr = linkCmd->objClientData;
+ dataPtr = (ImportedCmdData *)linkCmd->objClientData;
linkCmd = dataPtr->realCmdPtr;
if (overwrite == linkCmd) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1772,9 +1765,9 @@ DoImport(
}
}
- dataPtr = ckalloc(sizeof(ImportedCmdData));
+ dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
+ TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
@@ -1786,15 +1779,15 @@ DoImport(
* and add it to the import ref list in the "real" command.
*/
- refPtr = ckalloc(sizeof(ImportRef));
+ refPtr = (ImportRef *)ckalloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
- Command *overwrite = Tcl_GetHashValue(found);
+ Command *overwrite = (Command *)Tcl_GetHashValue(found);
if (overwrite->deleteProc == DeleteImportedCmd) {
- ImportedCmdData *dataPtr = overwrite->objClientData;
+ ImportedCmdData *dataPtr = (ImportedCmdData *)overwrite->objClientData;
if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) {
/*
@@ -1851,7 +1844,7 @@ Tcl_ForgetImport(
Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
const char *simplePattern;
char *cmdName;
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
@@ -1888,7 +1881,7 @@ Tcl_ForgetImport(
if (TclMatchIsTrivial(simplePattern)) {
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (hPtr != NULL) {
- Command *cmdPtr = Tcl_GetHashValue(hPtr);
+ Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
@@ -1898,12 +1891,12 @@ Tcl_ForgetImport(
}
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
- Command *cmdPtr = Tcl_GetHashValue(hPtr);
+ Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc != DeleteImportedCmd) {
continue;
}
- cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
+ cmdName = (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
@@ -1918,7 +1911,7 @@ Tcl_ForgetImport(
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_CmdInfo info;
- Tcl_Command token = Tcl_GetHashValue(hPtr);
+ Tcl_Command token = (Tcl_Command)Tcl_GetHashValue(hPtr);
Tcl_Command origin = TclGetOriginalCommand(token);
if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
@@ -1931,7 +1924,7 @@ Tcl_ForgetImport(
*/
Command *cmdPtr = (Command *) token;
- ImportedCmdData *dataPtr = cmdPtr->objClientData;
+ ImportedCmdData *dataPtr = (ImportedCmdData *)cmdPtr->objClientData;
Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
if (firstToken == origin) {
@@ -1978,7 +1971,7 @@ TclGetOriginalCommand(
Tcl_Command command) /* The imported command for which the original
* command should be returned. */
{
- register Command *cmdPtr = (Command *) command;
+ Command *cmdPtr = (Command *) command;
ImportedCmdData *dataPtr;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
@@ -1986,7 +1979,7 @@ TclGetOriginalCommand(
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
- dataPtr = cmdPtr->objClientData;
+ dataPtr = (ImportedCmdData *)cmdPtr->objClientData;
cmdPtr = dataPtr->realCmdPtr;
}
return (Tcl_Command) cmdPtr;
@@ -1995,7 +1988,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
@@ -2019,15 +2012,15 @@ InvokeImportedNRCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- ImportedCmdData *dataPtr = clientData;
+ ImportedCmdData *dataPtr = (ImportedCmdData *)clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
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. */
@@ -2064,10 +2057,10 @@ DeleteImportedCmd(
ClientData clientData) /* Points to the imported command's
* ImportedCmdData structure. */
{
- ImportedCmdData *dataPtr = clientData;
+ ImportedCmdData *dataPtr = (ImportedCmdData *)clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
Command *selfPtr = dataPtr->selfPtr;
- register ImportRef *refPtr, *prevPtr;
+ ImportRef *refPtr, *prevPtr;
prevPtr = NULL;
for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
@@ -2340,7 +2333,7 @@ TclGetNamespaceForQualName(
}
#endif
if (entryPtr != NULL) {
- nsPtr = Tcl_GetHashValue(entryPtr);
+ nsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
} else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame *framePtr;
@@ -2375,7 +2368,7 @@ TclGetNamespaceForQualName(
}
#endif
if (entryPtr != NULL) {
- altNsPtr = Tcl_GetHashValue(entryPtr);
+ altNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
} else {
altNsPtr = NULL;
}
@@ -2487,7 +2480,7 @@ Tcl_FindNamespace(
* points to namespace in which to resolve
* name; if NULL, look up name in the current
* namespace. */
- register int flags) /* Flags controlling namespace lookup: an OR'd
+ int flags) /* Flags controlling namespace lookup: an OR'd
* combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG flags. */
{
@@ -2558,8 +2551,8 @@ Tcl_FindCommand(
{
Interp *iPtr = (Interp *) interp;
Namespace *cxtNsPtr;
- register Tcl_HashEntry *entryPtr;
- register Command *cmdPtr;
+ Tcl_HashEntry *entryPtr;
+ Command *cmdPtr;
const char *simpleName;
int result;
@@ -2625,7 +2618,7 @@ Tcl_FindCommand(
|| !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
@@ -2646,7 +2639,7 @@ Tcl_FindCommand(
&& !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
@@ -2664,13 +2657,13 @@ Tcl_FindCommand(
&& !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
} else {
Namespace *nsPtr[2];
- register int search;
+ int search;
TclGetNamespaceForQualName(interp, name, cxtNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
@@ -2686,7 +2679,7 @@ Tcl_FindCommand(
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
@@ -2744,13 +2737,13 @@ TclResetShadowedCmdRefs(
{
char *cmdName;
Tcl_HashEntry *hPtr;
- register Namespace *nsPtr;
+ Namespace *nsPtr;
Namespace *trailNsPtr, *shadowNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
int found, i;
int trailFront = -1;
int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */
- Namespace **trailPtr = TclStackAlloc(interp,
+ Namespace **trailPtr = (Namespace **)TclStackAlloc(interp,
trailSize * sizeof(Namespace *));
/*
@@ -2770,7 +2763,7 @@ TclResetShadowedCmdRefs(
* cmdName.
*/
- cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
+ cmdName = (char *)Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;
nsPtr=nsPtr->parentPtr) {
/*
@@ -2799,7 +2792,7 @@ TclResetShadowedCmdRefs(
}
#endif
if (hPtr != NULL) {
- shadowNsPtr = Tcl_GetHashValue(hPtr);
+ shadowNsPtr = (Namespace *)Tcl_GetHashValue(hPtr);
} else {
found = 0;
break;
@@ -2840,7 +2833,7 @@ TclResetShadowedCmdRefs(
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
- trailPtr = TclStackRealloc(interp, trailPtr,
+ trailPtr = (Namespace **)TclStackRealloc(interp, trailPtr,
newSize * sizeof(Namespace *));
trailSize = newSize;
}
@@ -2908,26 +2901,29 @@ GetNamespaceFromObj(
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
ResolvedNsName *resNamePtr;
- Namespace *nsPtr, *refNsPtr;
- if (objPtr->typePtr == &nsNameType) {
+ NsNameGetIntRep(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_StoreIntRep(objPtr, &nsNameType, NULL);
}
if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
- resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ NsNameGetIntRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
@@ -2981,7 +2977,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. */
@@ -2991,7 +2987,7 @@ NamespaceChildrenCmd(
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
const char *pattern = NULL;
Tcl_DString buffer;
- register Tcl_HashEntry *entryPtr;
+ Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Obj *listPtr, *elemPtr;
@@ -3065,7 +3061,7 @@ NamespaceChildrenCmd(
entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
while (entryPtr != NULL) {
- childNsPtr = Tcl_GetHashValue(entryPtr);
+ childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
@@ -3110,14 +3106,14 @@ 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. */
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
- register const char *arg;
+ const char *arg;
int length;
if (objc != 2) {
@@ -3191,12 +3187,12 @@ 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. */
{
- register Namespace *currNsPtr;
+ Namespace *currNsPtr;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
@@ -3254,14 +3250,14 @@ 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. */
{
Tcl_Namespace *namespacePtr;
const char *name;
- register int i;
+ int i;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?name name...?");
@@ -3342,7 +3338,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. */
@@ -3428,13 +3424,13 @@ NsEval_Callback(
Tcl_Interp *interp,
int result)
{
- Tcl_Namespace *namespacePtr = data[0];
+ Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0];
if (result == TCL_ERROR) {
int length = strlen(namespacePtr->fullName);
int limit = 200;
int overflow = (length > limit);
- char *cmd = data[1];
+ char *cmd = (char *)data[1];
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in namespace %s \"%.*s%s\" script line %d)",
@@ -3474,7 +3470,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. */
@@ -3529,7 +3525,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. */
@@ -3610,13 +3606,13 @@ 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. */
{
const char *pattern;
- register int i, result;
+ int i, result;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?");
@@ -3675,14 +3671,14 @@ 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. */
{
int allowOverwrite = 0;
const char *string, *pattern;
- register int i, result;
+ int i, result;
int firstArg;
if (objc < 1) {
@@ -3715,11 +3711,11 @@ NamespaceImportCmd(
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- Command *cmdPtr = Tcl_GetHashValue(hPtr);
+ Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc == DeleteImportedCmd) {
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
- Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1));
+ (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1));
}
}
Tcl_SetObjResult(interp, listPtr);
@@ -3790,7 +3786,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. */
@@ -3835,7 +3831,7 @@ NRNamespaceInscopeCmd(
cmdObjPtr = objv[2];
} else {
Tcl_Obj *concatObjv[2];
- register Tcl_Obj *listPtr;
+ Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
for (i = 3; i < objc; i++) {
@@ -3887,7 +3883,7 @@ 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. */
@@ -3948,7 +3944,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. */
@@ -4006,7 +4002,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. */
@@ -4046,7 +4042,7 @@ NamespacePathCmd(
goto badNamespace;
}
if (nsObjc != 0) {
- namespaceList = TclStackAlloc(interp,
+ namespaceList = (Tcl_Namespace **)TclStackAlloc(interp,
sizeof(Tcl_Namespace *) * nsObjc);
for (i=0 ; i<nsObjc ; i++) {
@@ -4099,7 +4095,7 @@ TclSetNsPath(
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray =
- ckalloc(sizeof(NamespacePathEntry) * pathLength);
+ (NamespacePathEntry *)ckalloc(sizeof(NamespacePathEntry) * pathLength);
int i;
for (i=0 ; i<pathLength ; i++) {
@@ -4231,12 +4227,12 @@ 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. */
{
- register const char *name, *p;
+ const char *name, *p;
int length;
if (objc != 2) {
@@ -4299,7 +4295,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. */
@@ -4486,12 +4482,12 @@ 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. */
{
- register const char *name, *p;
+ const char *name, *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
@@ -4544,7 +4540,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. */
@@ -4618,7 +4614,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. */
@@ -4694,18 +4690,20 @@ NamespaceWhichCmd(
static void
FreeNsNameInternalRep(
- register Tcl_Obj *objPtr) /* nsName object with internal representation
+ Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
- ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
+
+ NsNameGetIntRep(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
@@ -4715,7 +4713,6 @@ FreeNsNameInternalRep(
TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree(resNamePtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -4740,13 +4737,13 @@ FreeNsNameInternalRep(
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ 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;
+ NsNameGetIntRep(srcPtr, resNamePtr);
+ assert(resNamePtr != NULL);
+ NsNameSetIntRep(copyPtr, resNamePtr);
}
/*
@@ -4776,11 +4773,11 @@ SetNsNameFromAny(
Tcl_Interp *interp, /* Points to the namespace in which to resolve
* name. Also used for error reporting if not
* NULL. */
- register Tcl_Obj *objPtr) /* The object to convert. */
+ Tcl_Obj *objPtr) /* The object to convert. */
{
const char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
- register ResolvedNsName *resNamePtr;
+ ResolvedNsName *resNamePtr;
const char *name;
if (interp == NULL) {
@@ -4791,36 +4788,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 intrep 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 = ckalloc(sizeof(ResolvedNsName));
+ 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;
+ NsNameSetIntRep(objPtr, resNamePtr);
return TCL_OK;
}
@@ -4872,7 +4858,7 @@ TclGetNamespaceChildTable(
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
- nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable));
+ nPtr->childTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
}
return nPtr->childTablePtr;
@@ -4914,7 +4900,7 @@ TclLogCommandInfo(
Tcl_Obj **tosPtr) /* Current stack of bytecode execution
* context */
{
- register const char *p;
+ const char *p;
Interp *iPtr = (Interp *) interp;
int overflow, limit = 150;
Var *varPtr, *arrayPtr;
@@ -4961,7 +4947,7 @@ TclLogCommandInfo(
} else {
Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
- VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
+ VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (tracePtr->traceProc != EstablishErrorInfoTraces) {
/*
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index e76bca8..65b4197 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -276,7 +276,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;
diff --git a/generic/tclOO.c b/generic/tclOO.c
index c1db80c..322daff 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -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
@@ -144,65 +145,10 @@ static const char *initScript =
/* " 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 +178,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,7 +253,7 @@ TclOOInit(
* to be fully provided.
*/
- if (Tcl_Eval(interp, initScript) != TCL_OK) {
+ if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
@@ -314,13 +296,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 +361,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");
+ 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;
+ }
- 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 +471,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 +502,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 +530,7 @@ static void
DeletedDefineNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->defineNs = NULL;
}
@@ -552,7 +539,7 @@ static void
DeletedObjdefNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->objdefNs = NULL;
}
@@ -561,7 +548,7 @@ static void
DeletedHelpersNamespace(
ClientData clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->helpersNs = NULL;
}
@@ -579,10 +566,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(ClientData),
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
{
Foundation *fPtr = GetFoundation(interp);
@@ -620,8 +606,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 +620,7 @@ AllocObject(
CommandTrace *tracePtr;
int creationEpoch;
- oPtr = ckalloc(sizeof(Object));
+ oPtr = (Object *)ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -718,8 +704,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 +720,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 +731,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 +739,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 +770,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 +785,18 @@ MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
- register Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
oPtr->myCommand = NULL;
}
+
+static void
+MyClassDeleted(
+ ClientData clientData)
+{
+ Object *oPtr = (Object *)clientData;
+ oPtr->myclassCommand = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -818,12 +814,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 +888,7 @@ TclOODeleteDescendants(
ckfree(clsPtr->mixinSubs.list);
clsPtr->mixinSubs.size = 0;
}
+
/*
* Squelch subclasses of this class.
*/
@@ -960,6 +958,7 @@ TclOOReleaseClassContents(
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
+ PrivateVariableMapping *privateVariable;
/*
* Sanity check!
@@ -976,6 +975,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 +1075,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 +1106,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 +1121,7 @@ ObjectNamespaceDeleted(
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
+
return;
}
@@ -1108,6 +1130,7 @@ ObjectNamespaceDeleted(
* process of being deleted, nothing else may modify its bookeeping
* records. This is the flag that
*/
+
oPtr->flags |= OBJECT_DESTRUCTING;
/*
@@ -1127,7 +1150,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;
@@ -1168,6 +1191,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 +1238,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 +1278,6 @@ ObjectNamespaceDeleted(
if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
&& !Tcl_InterpDeleted(interp)) {
-
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
@@ -1267,7 +1300,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 +1308,13 @@ ObjectNamespaceDeleted(
*
* ----------------------------------------------------------------------
*/
-int TclOODecrRefCount(Object *oPtr) {
+
+int
+TclOODecrRefCount(
+ Object *oPtr)
+{
if (oPtr->refCount-- <= 1) {
+
if (oPtr->classPtr != NULL) {
ckfree(oPtr->classPtr);
}
@@ -1301,21 +1339,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 +1390,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 +1489,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 +1554,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 +1575,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 +1602,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 +1610,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 +1619,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 +1637,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);
- }
-}
/*
* ----------------------------------------------------------------------
@@ -1632,12 +1662,14 @@ Tcl_NewObjectInstance(
int skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
- register Class *classPtr = (Class *) cls;
+ Class *classPtr = (Class *) cls;
Object *oPtr;
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 +1678,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;
@@ -1700,13 +1732,15 @@ TclNRNewObjectInstance(
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
{
- register Class *classPtr = (Class *) cls;
+ Class *classPtr = (Class *) cls;
CallContext *contextPtr;
Tcl_InterpState state;
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 +1751,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 +1790,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 +1847,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 +1920,7 @@ Tcl_CopyObjectInstance(
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+ PrivateVariableMapping *privateVariable;
int i, result;
/*
@@ -1959,7 +1994,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 +2002,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 +2070,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 +2100,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 +2108,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 +2191,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;
@@ -2318,7 +2368,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 +2448,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 +2480,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 +2490,8 @@ Tcl_ObjectSetMetadata(
* ----------------------------------------------------------------------
*/
-static int
-PublicObjectCmd(
+int
+TclOOPublicObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2457,12 +2507,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 +2528,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 +2565,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 +2626,9 @@ TclOOObjectCmdCore(
{
CallContext *contextPtr;
Tcl_Obj *methodNamePtr;
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+ Object *callerObjPtr = NULL;
+ Class *callerClsPtr = NULL;
int result;
/*
@@ -2553,12 +2643,30 @@ 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.
*/
methodNamePtr = objv[1];
if (oPtr->mapMethodNameProc != NULL) {
- register Class **startClsPtr = &startCls;
+ Class **startClsPtr = &startCls;
Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
@@ -2579,7 +2687,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 +2705,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"
@@ -2615,7 +2725,7 @@ TclOOObjectCmdCore(
if (startCls != NULL) {
for (; contextPtr->index < contextPtr->callPtr->numChain;
contextPtr->index++) {
- register struct MInvoke *miPtr =
+ struct MInvoke *miPtr =
&contextPtr->callPtr->chain[contextPtr->index];
if (miPtr->isFilter) {
@@ -2647,7 +2757,7 @@ TclOOObjectCmdCore(
static int
FinalizeObjectCall(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
/*
@@ -2655,7 +2765,7 @@ FinalizeObjectCall(
* structure.
*/
- TclOODeleteContext(data[0]);
+ TclOODeleteContext((CallContext *)data[0]);
return result;
}
@@ -2753,7 +2863,7 @@ TclNRObjectContextInvokeNext(
Tcl_Obj *const *objv,
int skip)
{
- register CallContext *contextPtr = (CallContext *) context;
+ CallContext *contextPtr = (CallContext *) context;
if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
@@ -2808,10 +2918,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 +2956,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(
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 265ba88..f1bb320 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,
ClientData 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,
ClientData clientData)
}
declare 13 {
@@ -126,6 +126,9 @@ declare 27 {
declare 28 {
Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
}
+declare 29 {
+ int Tcl_MethodIsPrivate(Tcl_Method method)
+}
######################################################################
# Private API, exposed to support advanced OO systems that plug in on top of
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 32afbf1..9c1dd1e 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,7 +24,7 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.1.0"
+#define TCLOO_VERSION "1.2.0"
#define TCLOO_PATCHLEVEL TCLOO_VERSION
#include "tcl.h"
@@ -99,6 +99,15 @@ typedef struct {
*/
#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 d874cba..9f7b526 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -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. */
@@ -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. */
@@ -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. */
@@ -399,7 +426,7 @@ TclOO_Object_Eval(
{
CallContext *contextPtr = (CallContext *) context;
Tcl_Object object = Tcl_ObjectContextObject(context);
- register const int skip = Tcl_ObjectContextSkippedArgs(context);
+ const int skip = Tcl_ObjectContextSkippedArgs(context);
CallFrame *framePtr, **framePtrPtr = &framePtr;
Tcl_Obj *scriptPtr;
CmdFrame *invoker;
@@ -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(
varNamePtr = Tcl_NewObj();
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
@@ -1028,7 +1122,7 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
- register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
@@ -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;
@@ -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 cc02c68..9191989 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -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, const 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);
/*
@@ -90,6 +152,7 @@ static const Tcl_ObjType methodNameType = {
NULL,
NULL
};
+
/*
* ----------------------------------------------------------------------
@@ -105,7 +168,7 @@ void
TclOODeleteContext(
CallContext *contextPtr)
{
- register Object *oPtr = contextPtr->oPtr;
+ Object *oPtr = contextPtr->oPtr;
TclOODeleteChain(contextPtr->callPtr);
if (oPtr != NULL) {
@@ -184,11 +247,12 @@ StashCallChain(
Tcl_Obj *objPtr,
CallChain *callPtr)
{
+ Tcl_ObjIntRep ir;
+
callPtr->refCount++;
TclGetString(objPtr);
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &methodNameType;
- objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
+ ir.twoPtrValue.ptr1 = callPtr;
+ Tcl_StoreIntRep(objPtr, &methodNameType, &ir);
}
void
@@ -215,21 +279,16 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
-
- dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
- callPtr->refCount++;
+ StashCallChain(dstPtr,
+ (CallChain *)TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
-
- TclOODeleteChain(callPtr);
- objPtr->typePtr = NULL;
+ TclOODeleteChain(
+ (CallChain *)TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
@@ -255,7 +314,7 @@ TclOOInvokeContext(
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The arguments as actually seen. */
{
- register CallContext *const contextPtr = clientData;
+ CallContext *const contextPtr = (CallContext *)clientData;
Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const int isFilter =
contextPtr->callPtr->chain[contextPtr->index].isFilter;
@@ -317,10 +376,10 @@ TclOOInvokeContext(
static int
SetFilterFlags(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
@@ -329,10 +388,10 @@ SetFilterFlags(
static int
ResetFilterFlags(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
@@ -341,10 +400,10 @@ ResetFilterFlags(
static int
FinalizeMethodRefs(
ClientData data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
int i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
@@ -366,6 +425,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
@@ -378,12 +445,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);
@@ -400,18 +465,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);
}
}
@@ -419,84 +479,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, (unsigned) 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
@@ -513,10 +535,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);
@@ -529,51 +548,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 = 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, (unsigned) 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
@@ -617,6 +686,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.
@@ -647,7 +718,6 @@ AddClassMethodNames(
if (clsPtr->mixins.num != 0) {
Class *mixinPtr;
- int i;
FOREACH(mixinPtr, clsPtr->mixins) {
if (mixinPtr != clsPtr) {
@@ -658,20 +728,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) {
@@ -681,7 +738,6 @@ AddClassMethodNames(
}
if (clsPtr->superclasses.num != 0) {
Class *superPtr;
- int i;
FOREACH(superPtr, clsPtr->superclasses) {
AddClassMethodNames(superPtr, flags, namesPtr,
@@ -693,19 +749,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. */
@@ -719,44 +877,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 = 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(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;
}
/*
@@ -792,7 +968,7 @@ AddMethodToCallChain(
* looking to add things from a mixin and have
* not passed a mixin. */
{
- register CallChain *callPtr = cbPtr->callChainPtr;
+ CallChain *callPtr = cbPtr->callChainPtr;
int i;
/*
@@ -819,8 +995,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;
@@ -861,11 +1037,11 @@ AddMethodToCallChain(
if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
callPtr->chain =
- ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
+ (struct MInvoke *)ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
memcpy(callPtr->chain, callPtr->staticChain,
sizeof(struct MInvoke) * callPtr->numChain);
} else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
- callPtr->chain = ckrealloc(callPtr->chain,
+ callPtr->chain = (struct MInvoke *)ckrealloc(callPtr->chain,
sizeof(struct MInvoke) * (callPtr->numChain + 1));
}
callPtr->chain[i].mPtr = mPtr;
@@ -908,6 +1084,7 @@ InitCallChain(
* ----------------------------------------------------------------------
*
* IsStillValid --
+ *
* Calculates whether the given call chain can be used for executing a
* method for the given object. The condition on a chain from a cached
* location being reusable is:
@@ -959,6 +1136,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. */
@@ -966,7 +1149,7 @@ TclOOGetCallContext(
CallContext *contextPtr;
CallChain *callPtr;
struct ChainBuilder cb;
- int i, count, doFilters;
+ int i, count, doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
@@ -1006,15 +1189,16 @@ TclOOGetCallContext(
* the object, and in the class).
*/
- const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+ const Tcl_ObjIntRep *irPtr;
+ const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
- if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) {
+ callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
- FreeMethodNameRep(cacheInThisObj);
+ Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL);
}
if (oPtr->flags & USE_CLASS_CACHE) {
@@ -1034,7 +1218,7 @@ TclOOGetCallContext(
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
- callPtr = Tcl_GetHashValue(hPtr);
+ callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
@@ -1046,7 +1230,7 @@ TclOOGetCallContext(
doFilters = 1;
}
- callPtr = ckalloc(sizeof(CallChain));
+ callPtr = (CallChain *)ckalloc(sizeof(CallChain));
InitCallChain(callPtr, oPtr, flags);
cb.callChainPtr = callPtr;
@@ -1058,10 +1242,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) {
@@ -1090,10 +1275,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);
@@ -1108,9 +1293,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
@@ -1128,22 +1319,23 @@ 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) {
oPtr->selfCls->classChainCache =
- ckalloc(sizeof(Tcl_HashTable));
+ (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
@@ -1151,7 +1343,7 @@ TclOOGetCallContext(
(char *) methodNameObj, &i);
} else {
if (oPtr->chainCache == NULL) {
- oPtr->chainCache = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->chainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
@@ -1177,7 +1369,7 @@ TclOOGetCallContext(
}
returnContext:
- contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
+ contextPtr = (CallContext *)TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
contextPtr->oPtr = oPtr;
/*
@@ -1244,10 +1436,9 @@ 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 = Tcl_GetHashValue(hPtr);
+ callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
@@ -1259,7 +1450,7 @@ TclOOGetStereotypeCallChain(
hPtr = NULL;
}
- callPtr = ckalloc(sizeof(CallChain));
+ callPtr = (CallChain *)ckalloc(sizeof(CallChain));
memset(callPtr, 0, sizeof(CallChain));
callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
callPtr->epoch = fPtr->epoch;
@@ -1289,9 +1480,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
@@ -1300,10 +1492,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) {
@@ -1313,7 +1505,7 @@ TclOOGetStereotypeCallChain(
} else {
if (hPtr == NULL) {
if (clsPtr->classChainCache == NULL) {
- clsPtr->classChainCache = ckalloc(sizeof(Tcl_HashTable));
+ clsPtr->classChainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
@@ -1383,9 +1575,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);
}
}
@@ -1412,6 +1604,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.
@@ -1419,7 +1693,7 @@ AddClassFiltersToCallContext(
* ----------------------------------------------------------------------
*/
-static void
+static int
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
@@ -1435,7 +1709,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;
/*
@@ -1448,8 +1722,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) {
@@ -1462,21 +1737,26 @@ AddSimpleClassChainToCallContext(
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) methodNameObj);
+ if (classPtr->flags & HAS_PRIVATE_METHODS) {
+ privateDanger |= 1;
+ }
if (hPtr != NULL) {
- register Method *mPtr = Tcl_GetHashValue(hPtr);
-
- if (!(flags & KNOWN_STATE)) {
- if (flags & PUBLIC_METHOD) {
- if (mPtr->flags & PUBLIC_METHOD) {
+ Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
+
+ 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);
}
}
@@ -1486,11 +1766,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;
}
}
@@ -1510,7 +1791,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;
@@ -1519,12 +1800,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
@@ -1538,20 +1821,19 @@ TclOORenderCallChain(
* method (or "object" if it is declared on the instance).
*/
- objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
- descObjs[0] = miPtr->isFilter
- ? filterLiteral
- : callPtr->flags & OO_UNKNOWN_METHOD
- ? fPtr->unknownMethodNameObj
- : methodLiteral;
- descObjs[1] = callPtr->flags & CONSTRUCTOR
- ? fPtr->constructorName
- : callPtr->flags & DESTRUCTOR
- ? fPtr->destructorName
- : miPtr->mPtr->namePtr;
+ 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 :
+ callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
+ miPtr->mPtr->namePtr;
descObjs[2] = miPtr->mPtr->declaringClassPtr
? Tcl_GetObjectName(interp,
(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
@@ -1569,6 +1851,7 @@ TclOORenderCallChain(
Tcl_DecrRefCount(filterLiteral);
Tcl_DecrRefCount(methodLiteral);
Tcl_DecrRefCount(objectLiteral);
+ Tcl_DecrRefCount(privateLiteral);
/*
* Finish building the description and return it.
@@ -1580,6 +1863,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 9fd62ec..928d07e 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,
ClientData 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,
ClientData clientData);
/* 13 */
@@ -116,6 +116,8 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp,
/* 28 */
TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
Tcl_Object object);
+/* 29 */
+TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
@@ -136,8 +138,8 @@ typedef struct TclOOStubs {
int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *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, ClientData clientData); /* 11 */
- Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
+ Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
+ Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData 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 */
@@ -154,6 +156,7 @@ 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 */
+ int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
} TclOOStubs;
extern const TclOOStubs *tclOOStubsPtr;
@@ -226,6 +229,8 @@ extern const TclOOStubs *tclOOStubsPtr;
(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
#define Tcl_GetObjectName \
(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
+#define Tcl_MethodIsPrivate \
+ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
#endif /* defined(USE_TCLOO_STUBS) */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 2ace60c..76cf4ed 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -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,8 +778,8 @@ FindCommand(
Tcl_Namespace *const namespacePtr)
{
int length;
- const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
- register Namespace *const nsPtr = (Namespace *) namespacePtr;
+ 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
@@ -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, (int *) &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);
@@ -1832,9 +2290,14 @@ TclOODefineSlots(
&slotInfoPtr->getterType, NULL);
Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
+ if (slotInfoPtr->resolverType.callProc) {
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ &slotInfoPtr->resolverType, NULL);
+ }
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
+ Tcl_DecrRefCount(resolveName);
return TCL_OK;
}
@@ -1842,6 +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,
@@ -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,
@@ -1996,7 +2461,7 @@ ClassMixinSet(
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,
@@ -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(
}
resultObj = Tcl_NewObj();
- 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) {
@@ -2265,7 +2742,7 @@ ClassVarsSet(
}
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,
@@ -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,
@@ -2466,7 +2907,7 @@ ObjMixinSet(
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(
}
resultObj = Tcl_NewObj();
- 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,
@@ -2546,7 +2998,7 @@ ObjVarsSet(
}
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 c9263b5..3758d55 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -224,7 +228,7 @@ InfoObjectClassCmd(
static int
InfoObjectDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -337,7 +341,7 @@ InfoObjectFiltersCmd(
static int
InfoObjectForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -513,21 +517,28 @@ InfoObjectIsACmd(
static int
InfoObjectMethodsCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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;
+ }
+ }
resultObj = Tcl_NewObj();
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(ClientData),
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(ClientData),
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(ClientData),
+ 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_NewIntObj(oPtr->creationEpoch));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoObjectNsCmd --
*
* Implements [info object namespace $objName]
@@ -695,7 +769,7 @@ InfoObjectMixinsCmd(
static int
InfoObjectNsCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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(ClientData),
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;
}
resultObj = Tcl_NewObj();
- 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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -827,7 +917,7 @@ InfoObjectVarsCmd(
static int
InfoClassConstrCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -888,7 +978,7 @@ InfoClassConstrCmd(
static int
InfoClassDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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(ClientData),
+ 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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1000,7 +1140,7 @@ InfoClassDestrCmd(
static int
InfoClassFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1038,7 +1178,7 @@ InfoClassFiltersCmd(
static int
InfoClassForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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(ClientData),
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(ClientData),
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;
+ }
+ }
resultObj = Tcl_NewObj();
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(ClientData),
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1314,7 +1487,7 @@ InfoClassMixinsCmd(
static int
InfoClassSubsCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1369,7 +1542,7 @@ InfoClassSubsCmd(
static int
InfoClassSupersCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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(ClientData),
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;
}
resultObj = Tcl_NewObj();
- 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(ClientData),
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 0e4503a..db4b7f1 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -47,7 +47,7 @@ typedef struct Method {
* special flag record which is just used for
* the setting of the flags field. */
int refCount;
- ClientData clientData; /* Type-specific data. */
+ void *clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
struct Object *declaringObjectPtr;
/* The object that declares this method, or
@@ -84,7 +84,7 @@ typedef struct ProcedureMethod {
* body bytecodes. */
int flags; /* Flags to control features. */
int refCount;
- ClientData clientData;
+ void *clientData;
TclOO_PmCDDeleteProc *deleteClientdataProc;
TclOO_PmCDCloneProc *cloneClientdataProc;
ProcErrorProc *errProc; /* Replacement error handler. */
@@ -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 HAS_PRIVATE_METHODS 0x20000
+ /* Object/class has (or had) private methods,
+ * and so shouldn't be cached so
+ * aggressively. */
+#define DONT_DELETE 0x40000 /* 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. */
/*
* 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;
/*
@@ -368,10 +420,15 @@ typedef struct CallContext {
#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */
#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances
- * only) method. */
+ * only) method. Supports itcl. */
#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.
@@ -399,6 +456,9 @@ MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -426,6 +486,12 @@ MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -504,7 +570,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 +582,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 +634,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
+ * varable set to a pointer to each of those elements in turn.
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH_STRUCT(var,ary) \
+ for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++)
+
+/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* 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 493c936..b1b3d8e 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -67,7 +67,7 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv, int toRewrite,
int rewriteLength, Tcl_Obj *const *rewriteObjs,
int *lengthPtr);
-static int InvokeProcedureMethod(ClientData clientData,
+static int InvokeProcedureMethod(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static Tcl_NRPostProc FinalizeForwardCall;
@@ -77,29 +77,21 @@ static int PushMethodCallFrame(Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv,
PMFrameData *fdPtr);
static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
-static void DeleteProcedureMethod(ClientData clientData);
+static void DeleteProcedureMethod(void *clientData);
static int CloneProcedureMethod(Tcl_Interp *interp,
- ClientData clientData, ClientData *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 Tcl_Obj * RenderDeclarerName(ClientData clientData);
-static int InvokeForwardMethod(ClientData clientData,
+ void *clientData, void **newClientData);
+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,
int objc, Tcl_Obj *const *objv);
-static void DeleteForwardMethod(ClientData clientData);
+static void DeleteForwardMethod(void *clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
- ClientData clientData, ClientData *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);
+ void *clientData, void **newClientData);
+static Tcl_ResolveVarProc ProcedureMethodVarResolver;
+static Tcl_ResolveCompiledVarProc ProcedureMethodCompiledVarResolver;
/*
* The types of methods defined by the core OO system.
@@ -121,7 +113,7 @@ static const Tcl_MethodType fwdMethodType = {
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
- ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
/*
* ----------------------------------------------------------------------
@@ -135,7 +127,7 @@ static const Tcl_MethodType fwdMethodType = {
Tcl_Method
Tcl_NewInstanceMethod(
- Tcl_Interp *interp, /* Unused? */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
@@ -146,34 +138,34 @@ Tcl_NewInstanceMethod(
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
- ClientData clientData) /* Some data associated with the particular
+ void *clientData) /* Some data associated with the particular
* method to be created. */
{
- register Object *oPtr = (Object *) object;
- register Method *mPtr;
+ Object *oPtr = (Object *) object;
+ Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
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;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
if (isNew) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = nameObj;
mPtr->refCount = 1;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
@@ -186,7 +178,11 @@ Tcl_NewInstanceMethod(
mPtr->declaringObjectPtr = oPtr;
mPtr->declaringClassPtr = NULL;
if (flags) {
- mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ mPtr->flags |= flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+ if (flags & TRUE_PRIVATE_METHOD) {
+ oPtr->flags |= HAS_PRIVATE_METHODS;
+ }
}
oPtr->epoch++;
return (Tcl_Method) mPtr;
@@ -204,7 +200,7 @@ Tcl_NewInstanceMethod(
Tcl_Method
Tcl_NewMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
@@ -214,29 +210,29 @@ Tcl_NewMethod(
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
- ClientData clientData) /* Some data associated with the particular
+ void *clientData) /* Some data associated with the particular
* method to be created. */
{
- register Class *clsPtr = (Class *) cls;
- register Method *mPtr;
+ Class *clsPtr = (Class *) cls;
+ Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
if (isNew) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = nameObj;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
@@ -250,7 +246,11 @@ Tcl_NewMethod(
mPtr->declaringObjectPtr = NULL;
mPtr->declaringClassPtr = clsPtr;
if (flags) {
- mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ mPtr->flags |= flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+ if (flags & TRUE_PRIVATE_METHOD) {
+ clsPtr->flags |= HAS_PRIVATE_METHODS;
+ }
}
return (Tcl_Method) mPtr;
@@ -336,13 +336,13 @@ TclOONewProcInstanceMethod(
* interested. */
{
int argsLen;
- register ProcedureMethod *pmPtr;
+ ProcedureMethod *pmPtr;
Tcl_Method method;
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
- pmPtr = ckalloc(sizeof(ProcedureMethod));
+ pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
@@ -388,7 +388,7 @@ TclOONewProcMethod(
* interested. */
{
int argsLen; /* -1 => delete argsObj before exit */
- register ProcedureMethod *pmPtr;
+ ProcedureMethod *pmPtr;
const char *procName;
Tcl_Method method;
@@ -403,7 +403,7 @@ TclOONewProcMethod(
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
- pmPtr = ckalloc(sizeof(ProcedureMethod));
+ pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
@@ -450,7 +450,7 @@ TclOOMakeProcInstanceMethod(
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
- ClientData clientData, /* The per-method type-specific data. */
+ void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
@@ -497,12 +497,12 @@ TclOOMakeProcInstanceMethod(
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
- CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+ CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
- cfPtr->line = ckalloc(sizeof(int));
+ cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = context.line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -563,7 +563,7 @@ TclOOMakeProcMethod(
* NULL. */
const Tcl_MethodType *typePtr,
/* The type of the method to create. */
- ClientData clientData, /* The per-method type-specific data. */
+ void *clientData, /* The per-method type-specific data. */
Proc **procPtrPtr) /* A pointer to the variable in which to write
* the procedure record reference. Presumably
* inside the structure indicated by the
@@ -610,12 +610,12 @@ TclOOMakeProcMethod(
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
- CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+ CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
- cfPtr->line = ckalloc(sizeof(int));
+ cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = context.line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -658,13 +658,13 @@ TclOOMakeProcMethod(
static int
InvokeProcedureMethod(
- ClientData clientData, /* Pointer to some per-method context. */
+ void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
- ProcedureMethod *pmPtr = clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
int result;
PMFrameData *fdPtr; /* Important data that has to have a lifetime
* matched by this function (or rather, by the
@@ -686,7 +686,7 @@ InvokeProcedureMethod(
* Allocate the special frame data.
*/
- fdPtr = TclStackAlloc(interp, sizeof(PMFrameData));
+ fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData));
/*
* Create a call frame for this method.
@@ -739,13 +739,13 @@ InvokeProcedureMethod(
static int
FinalizePMCall(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
- ProcedureMethod *pmPtr = data[0];
- Tcl_ObjectContext context = data[1];
- PMFrameData *fdPtr = data[2];
+ ProcedureMethod *pmPtr = (ProcedureMethod *)data[0];
+ Tcl_ObjectContext context = (Tcl_ObjectContext)data[1];
+ PMFrameData *fdPtr = (PMFrameData *)data[2];
/*
* Give the post-call callback a chance to do some cleanup. Note that at
@@ -790,9 +790,10 @@ PushMethodCallFrame(
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
- register int result;
+ int result;
const char *namePtr;
CallFrame **framePtrPtr = &fdPtr->framePtr;
+ ByteCode *codePtr;
/*
* Compute basic information on the basis of the type of method it is.
@@ -822,7 +823,7 @@ PushMethodCallFrame(
*/
if (pmPtr->flags & USE_DECLARER_NS) {
- register Method *mPtr =
+ Method *mPtr =
contextPtr->callPtr->chain[contextPtr->index].mPtr;
if (mPtr->declaringClassPtr != NULL) {
@@ -858,10 +859,8 @@ PushMethodCallFrame(
* alternative is *so* slow...
*/
- if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
- ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
-
+ ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr) {
codePtr->nsPtr = nsPtr;
}
result = TclProcCompileProc(interp, pmPtr->procPtr,
@@ -895,7 +894,7 @@ PushMethodCallFrame(
fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
fdPtr->efi.fields[1].clientData = pmPtr;
} else {
- register Tcl_Method method =
+ Tcl_Method method =
Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
if (Tcl_MethodDeclarerObject(method) != NULL) {
@@ -930,7 +929,7 @@ PushMethodCallFrame(
* variables used in methods. The compiled variable resolver is more
* important, but both are needed as it is possible to have a variable
* that is only referred to in ways that aren't compilable and we can't
- * force LVT presence. [TIP #320]
+ * force LVT presence. [TIP #320, #500]
*
* ----------------------------------------------------------------------
*/
@@ -953,7 +952,7 @@ ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
- int flags,
+ TCL_UNUSED(int) /*flags*/, /* Ignoring variable access flags (???) */
Tcl_Var *varPtr)
{
int result;
@@ -986,6 +985,7 @@ ProcedureMethodCompiledVarConnect(
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
+ PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
int i, isNew, cacheIt, varLen, len;
const char *match, *varName;
@@ -999,7 +999,7 @@ ProcedureMethodCompiledVarConnect(
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return NULL;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
/*
* If we've done the work before (in a comparable context) then reuse that
@@ -1019,6 +1019,15 @@ ProcedureMethodCompiledVarConnect(
varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
if (contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr != NULL) {
+ FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr->privateVariables) {
+ match = TclGetStringFromObj(privateVar->variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ variableObj = privateVar->fullNameObj;
+ cacheIt = 0;
+ goto gotMatch;
+ }
+ }
FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
@@ -1028,6 +1037,14 @@ ProcedureMethodCompiledVarConnect(
}
}
} else {
+ FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
+ match = TclGetStringFromObj(privateVar->variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ variableObj = privateVar->fullNameObj;
+ cacheIt = 1;
+ goto gotMatch;
+ }
+ }
FOREACH(variableObj, contextPtr->oPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
if ((len == varLen) && !memcmp(match, varName, len)) {
@@ -1082,10 +1099,10 @@ ProcedureMethodCompiledVarDelete(
static int
ProcedureMethodCompiledVarResolver(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *varName,
int length,
- Tcl_Namespace *contextNs,
+ TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
@@ -1102,7 +1119,7 @@ ProcedureMethodCompiledVarResolver(
return TCL_CONTINUE;
}
- infoPtr = ckalloc(sizeof(OOResVarInfo));
+ infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo));
infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
infoPtr->cachedObjectVar = NULL;
@@ -1127,9 +1144,9 @@ ProcedureMethodCompiledVarResolver(
static Tcl_Obj *
RenderDeclarerName(
- ClientData clientData)
+ void *clientData)
{
- struct PNI *pni = clientData;
+ struct PNI *pni = (struct PNI *)clientData;
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
if (object == NULL) {
@@ -1153,6 +1170,8 @@ RenderDeclarerName(
* ----------------------------------------------------------------------
*/
+/* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */
+
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
@@ -1160,13 +1179,14 @@ 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 = ((Interp *) interp)->varFramePtr->clientData;
+ 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;
if (mPtr->declaringObjectPtr != NULL) {
@@ -1191,9 +1211,10 @@ MethodErrorHandler(
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* Ignore. We know it is the constructor. */
{
- CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
@@ -1220,9 +1241,10 @@ ConstructorErrorHandler(
static void
DestructorErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* Ignore. We know it is the destructor. */
{
- CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
+ CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
@@ -1269,9 +1291,9 @@ DeleteProcedureMethodRecord(
static void
DeleteProcedureMethod(
- ClientData clientData)
+ void *clientData)
{
- register ProcedureMethod *pmPtr = clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
if (pmPtr->refCount-- <= 1) {
DeleteProcedureMethodRecord(pmPtr);
@@ -1281,10 +1303,10 @@ DeleteProcedureMethod(
static int
CloneProcedureMethod(
Tcl_Interp *interp,
- ClientData clientData,
- ClientData *newClientData)
+ void *clientData,
+ void **newClientData)
{
- ProcedureMethod *pmPtr = clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
ProcedureMethod *pm2Ptr;
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
@@ -1315,14 +1337,14 @@ CloneProcedureMethod(
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
Tcl_GetString(bodyObj);
- TclFreeIntRep(bodyObj);
+ Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
- pm2Ptr = ckalloc(sizeof(ProcedureMethod));
+ pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
Tcl_IncrRefCount(argsObj);
@@ -1364,7 +1386,7 @@ TclOONewForwardInstanceMethod(
* prefix to forward to. */
{
int prefixLen;
- register ForwardMethod *fmPtr;
+ ForwardMethod *fmPtr;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
@@ -1376,7 +1398,7 @@ TclOONewForwardInstanceMethod(
return NULL;
}
- fmPtr = ckalloc(sizeof(ForwardMethod));
+ fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
@@ -1403,7 +1425,7 @@ TclOONewForwardMethod(
* prefix to forward to. */
{
int prefixLen;
- register ForwardMethod *fmPtr;
+ ForwardMethod *fmPtr;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
@@ -1415,7 +1437,7 @@ TclOONewForwardMethod(
return NULL;
}
- fmPtr = ckalloc(sizeof(ForwardMethod));
+ fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
@@ -1435,14 +1457,14 @@ TclOONewForwardMethod(
static int
InvokeForwardMethod(
- ClientData clientData, /* Pointer to some per-method context. */
+ void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
- ForwardMethod *fmPtr = clientData;
+ ForwardMethod *fmPtr = (ForwardMethod *)clientData;
Tcl_Obj **argObjs, **prefixObjs;
int numPrefixes, len, skip = contextPtr->skip;
@@ -1469,11 +1491,11 @@ InvokeForwardMethod(
static int
FinalizeForwardCall(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **argObjs = data[0];
+ Tcl_Obj **argObjs = (Tcl_Obj **)data[0];
TclStackFree(interp, argObjs);
return result;
@@ -1491,9 +1513,9 @@ FinalizeForwardCall(
static void
DeleteForwardMethod(
- ClientData clientData)
+ void *clientData)
{
- ForwardMethod *fmPtr = clientData;
+ ForwardMethod *fmPtr = (ForwardMethod *)clientData;
Tcl_DecrRefCount(fmPtr->prefixObj);
ckfree(fmPtr);
@@ -1501,12 +1523,12 @@ DeleteForwardMethod(
static int
CloneForwardMethod(
- Tcl_Interp *interp,
- ClientData clientData,
- ClientData *newClientData)
+ TCL_UNUSED(Tcl_Interp *),
+ void *clientData,
+ void **newClientData)
{
- ForwardMethod *fmPtr = clientData;
- ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
+ ForwardMethod *fmPtr = (ForwardMethod *)clientData;
+ ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
@@ -1530,7 +1552,7 @@ TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
- ProcedureMethod *pmPtr = mPtr->clientData;
+ ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
return pmPtr->procPtr;
}
@@ -1542,11 +1564,9 @@ TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
- ProcedureMethod *pmPtr = mPtr->clientData;
+ 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;
@@ -1557,7 +1577,7 @@ TclOOGetFwdFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &fwdMethodType) {
- ForwardMethod *fwPtr = mPtr->clientData;
+ ForwardMethod *fwPtr = (ForwardMethod *)mPtr->clientData;
return fwPtr->prefixObj;
}
@@ -1599,7 +1619,7 @@ InitEnsembleRewrite(
* array of rewritten arguments. */
{
unsigned len = rewriteLength + objc - toRewrite;
- Tcl_Obj **argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
+ Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
memcpy(argObjs + rewriteLength, objv + toRewrite,
@@ -1654,7 +1674,7 @@ int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Method *mPtr = (Method *) method;
@@ -1673,6 +1693,13 @@ Tcl_MethodIsPublic(
{
return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
}
+
+int
+Tcl_MethodIsPrivate(
+ Tcl_Method method)
+{
+ return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
+}
/*
* Extended method construction for itcl-ng.
@@ -1685,7 +1712,7 @@ TclOONewProcInstanceMethodEx(
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc,
- ClientData clientData,
+ void *clientData,
Tcl_Obj *nameObj, /* The name of the method, which must not be
* NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
@@ -1722,7 +1749,7 @@ TclOONewProcMethodEx(
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc,
- ClientData clientData,
+ void *clientData,
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
* if so, up to caller to manage storage
* (e.g., because it is a constructor or
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
new file mode 100644
index 0000000..a1e4624
--- /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 {}} {body {}}} {\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 $body\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 900ab22..5e235f4 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -73,6 +73,7 @@ const TclOOStubs tclOOStubs = {
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
+ Tcl_MethodIsPrivate, /* 29 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclObj.c b/generic/tclObj.c
index a4df3e7..dbe6686 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -15,8 +15,9 @@
*/
#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. */
@@ -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
/*
@@ -178,30 +178,16 @@ static Tcl_ThreadDataKey pendingObjDataKey;
#define PACK_BIGNUM(bignum, objPtr) \
if ((bignum).used > 0x7FFF) { \
- mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
+ mp_int *temp = (mp_int *) ckalloc(sizeof(mp_int)); \
*temp = bignum; \
(objPtr)->internalRep.twoPtrValue.ptr1 = temp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
- } else { \
- if ((bignum).alloc > 0x7FFF) { \
- mp_shrink(&(bignum)); \
- } \
+ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
-#define UNPACK_BIGNUM(objPtr, bignum) \
- if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \
- (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \
- } else { \
- (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \
- (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \
- (bignum).alloc = \
- (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \
- (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \
- }
-
/*
* Prototypes for functions defined later in this file:
*/
@@ -211,9 +197,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef TCL_WIDE_INT_IS_LONG
-static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
-static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void UpdateStringOfOldInt(Tcl_Obj *objPtr);
#endif
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -243,6 +228,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
@@ -250,6 +236,7 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
+#endif
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
@@ -265,19 +252,23 @@ const Tcl_ObjType tclDoubleType = {
SetDoubleFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclIntType = {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG)
"int", /* name */
+#else
+ "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/
+#endif
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-#ifndef TCL_WIDE_INT_IS_LONG
-const Tcl_ObjType tclWideIntType = {
- "wideInt", /* name */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static const Tcl_ObjType oldIntType = {
+ "int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfWideInt, /* updateStringProc */
- SetWideIntFromAny /* setFromAnyProc */
+ UpdateStringOfOldInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBignumType = {
@@ -345,23 +336,23 @@ typedef struct ResolvedCmdName {
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
- long refNsId; /* refNsPtr's unique namespace id. Used to
+ unsigned long refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
- int refNsCmdEpoch; /* Value of the referencing namespace's
+ unsigned int refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
- int cmdEpoch; /* Value of the command's cmdEpoch when this
+ unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName object
+ size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -396,21 +387,21 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
- Tcl_RegisterObjType(&tclEndOffsetType);
- Tcl_RegisterObjType(&tclIntType);
Tcl_RegisterObjType(&tclStringType);
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 +439,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 +448,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);
@@ -541,7 +532,7 @@ TclGetContLineTable(void)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
- tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
+ tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
@@ -576,7 +567,7 @@ TclContinuationsEnter(
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
- ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
+ ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
if (!newEntry) {
/*
@@ -733,7 +724,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 +760,7 @@ TclContinuationsGet(
if (!hPtr) {
return NULL;
}
- return Tcl_GetHashValue(hPtr);
+ return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
@@ -792,7 +783,7 @@ TclContinuationsGet(
static void
TclThreadFinalizeContLines(
- ClientData clientData)
+ TCL_UNUSED(ClientData))
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -876,7 +867,7 @@ Tcl_AppendAllObjTypes(
* name of each registered type is appended as
* a list element. */
{
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int numElems;
@@ -897,7 +888,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;
@@ -924,13 +915,13 @@ const Tcl_ObjType *
Tcl_GetObjType(
const char *typeName) /* Name of Tcl object type to look up. */
{
- register Tcl_HashEntry *hPtr;
+ Tcl_HashEntry *hPtr;
const Tcl_ObjType *typePtr = NULL;
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 +992,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 +1008,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 +1021,14 @@ TclDbDumpActiveObjects(
}
}
}
-#endif
}
+#else
+void
+TclDbDumpActiveObjects(
+ TCL_UNUSED(FILE *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -1054,18 +1051,17 @@ TclDbDumpActiveObjects(
#ifdef TCL_MEM_DEBUG
void
TclDbInitNewObj(
- register Tcl_Obj *objPtr,
- register const char *file, /* The name of the source file calling this
+ Tcl_Obj *objPtr,
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
- register int line) /* Line number in the source file; used for
+ int line) /* Line number in the source file; used for
* 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.
@@ -1079,7 +1075,7 @@ TclDbInitNewObj(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
- tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable));
+ tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
@@ -1092,7 +1088,7 @@ TclDbInitNewObj(
* Record the debugging information.
*/
- objData = ckalloc(sizeof(ObjData));
+ objData = (ObjData *)ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
@@ -1142,7 +1138,7 @@ Tcl_NewObj(void)
Tcl_Obj *
Tcl_NewObj(void)
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
@@ -1184,12 +1180,12 @@ Tcl_NewObj(void)
Tcl_Obj *
Tcl_DbNewObj(
- register const char *file, /* The name of the source file calling this
+ const char *file, /* The name of the source file calling this
* function; used for debugging. */
- register int line) /* Line number in the source file; used for
+ int line) /* Line number in the source file; used for
* debugging. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
@@ -1202,10 +1198,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();
}
@@ -1239,8 +1233,8 @@ TclAllocateFreeObjects(void)
{
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
- register Tcl_Obj *prevPtr, *objPtr;
- register int i;
+ Tcl_Obj *prevPtr, *objPtr;
+ int i;
/*
* This has been noted by Purify to be a potential leak. The problem is
@@ -1251,7 +1245,7 @@ TclAllocateFreeObjects(void)
* Purify apparently can't figure that out, and fires a false alarm.
*/
- basePtr = ckalloc(bytesToAlloc);
+ basePtr = (char *)ckalloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
@@ -1291,9 +1285,9 @@ TclAllocateFreeObjects(void)
#ifdef TCL_MEM_DEBUG
void
TclFreeObj(
- register Tcl_Obj *objPtr) /* The object to be freed. */
+ Tcl_Obj *objPtr) /* The object to be freed. */
{
- register const Tcl_ObjType *typePtr = objPtr->typePtr;
+ const Tcl_ObjType *typePtr = objPtr->typePtr;
/*
* This macro declares a variable, so must come here...
@@ -1301,7 +1295,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 +1317,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);
@@ -1416,7 +1410,7 @@ TclFreeObj(
void
TclFreeObj(
- register Tcl_Obj *objPtr) /* The object to be freed. */
+ Tcl_Obj *objPtr) /* The object to be freed. */
{
/*
* Invalidate the string rep first so we can use the bytes value for our
@@ -1625,35 +1619,33 @@ TclSetDuplicateObj(
char *
Tcl_GetString(
- register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
+ 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;
}
@@ -1683,14 +1675,37 @@ Tcl_GetString(
char *
Tcl_GetStringFromObj(
- register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
+ Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
- register int *lengthPtr) /* If non-NULL, the location where the string
+ int *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
- (void) TclGetString(objPtr);
+ if (objPtr->bytes == NULL) {
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
+ */
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep",
+ objPtr->typePtr->name);
+ }
+ }
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
@@ -1700,6 +1715,91 @@ Tcl_GetStringFromObj(
/*
*----------------------------------------------------------------------
*
+ * Tcl_InitStringRep --
+ *
+ * This function is called in several configurations to provide all
+ * the tools needed to set an object's string representation. The
+ * function is determined by the arguments.
+ *
+ * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0)
+ * Invalid call -- panic!
+ *
+ * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0
+ * Allocation only - allocate space for (numBytes+1) chars.
+ * store in objPtr->bytes and return. Also sets
+ * objPtr->length to 0 and objPtr->bytes[0] to NUL.
+ *
+ * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0
+ * Allocate and copy. bytes is assumed to point to chars to
+ * copy into the string rep. objPtr->length = numBytes. Allocate
+ * array of (numBytes + 1) chars. store in objPtr->bytes. Copy
+ * numBytes chars from bytes to objPtr->bytes; Set
+ * objPtr->bytes[numBytes] to NUL and return objPtr->bytes.
+ * Caller must guarantee there are numBytes chars at bytes to
+ * be copied.
+ *
+ * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0
+ * Truncate. Set objPtr->length to numBytes and
+ * objPr->bytes[numBytes] to NUL. Caller has to guarantee
+ * that a prior allocating call allocated enough bytes for
+ * this to be valid. Return objPtr->bytes.
+ *
+ * Caller is expected to ascertain that the bytes copied into
+ * the string rep make up complete valid UTF-8 characters.
+ *
+ * Results:
+ * A pointer to the string rep of objPtr.
+ *
+ * Side effects:
+ * As described above.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_InitStringRep(
+ Tcl_Obj *objPtr, /* Object whose string rep is to be set */
+ const char *bytes,
+ unsigned int numBytes)
+{
+ assert(objPtr->bytes == NULL || bytes == NULL);
+
+ if (numBytes > INT_MAX) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ /* Allocate */
+ if (objPtr->bytes == NULL) {
+ /* Allocate only as empty - extend later if bytes copied */
+ objPtr->length = 0;
+ if (numBytes) {
+ objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
+ if (objPtr->bytes == NULL) {
+ return NULL;
+ }
+ if (bytes) {
+ /* Copy */
+ memcpy(objPtr->bytes, bytes, numBytes);
+ objPtr->length = (int) numBytes;
+ }
+ } else {
+ TclInitStringRep(objPtr, NULL, 0);
+ }
+ } else {
+ /* objPtr->bytes != NULL bytes == NULL - Truncate */
+ objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes + 1);
+ objPtr->length = (int)numBytes;
+ }
+
+ /* Terminate */
+ objPtr->bytes[objPtr->length] = '\0';
+
+ return objPtr->bytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_InvalidateStringRep --
*
* This function is called to invalidate an object's string
@@ -1717,7 +1817,7 @@ Tcl_GetStringFromObj(
void
Tcl_InvalidateStringRep(
- register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
+ Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be freed. */
{
TclInvalidateStringRep(objPtr);
@@ -1726,6 +1826,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_StoreIntRep --
+ *
+ * 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 IntRep 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_StoreIntRep(
+ Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
+ const Tcl_ObjType *typePtr, /* New type for the object */
+ const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */
+{
+ /* Clear out any existing IntRep ( "shimmer" ) */
+ TclFreeIntRep(objPtr);
+
+ /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */
+ if (irPtr) {
+ /* Copy the new IntRep into place */
+ objPtr->internalRep = *irPtr;
+
+ /* Set the type to match */
+ objPtr->typePtr = typePtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FetchIntRep --
+ *
+ * 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_ObjIntRep, 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_ObjIntRep *
+Tcl_FetchIntRep(
+ Tcl_Obj *objPtr, /* Object to fetch from. */
+ const Tcl_ObjType *typePtr) /* Requested type */
+{
+ return TclFetchIntRep(objPtr, typePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeIntRep --
+ *
+ * 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_FreeIntRep(
+ Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */
+{
+ TclFreeIntRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_NewBooleanObj --
*
* This function is normally called when not debugging: i.e., when
@@ -1734,7 +1945,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
@@ -1751,20 +1962,20 @@ Tcl_InvalidateStringRep(
Tcl_Obj *
Tcl_NewBooleanObj(
- register int boolValue) /* Boolean used to initialize new object. */
+ int boolValue) /* Boolean used to initialize new object. */
{
- return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(boolValue!=0, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewBooleanObj(
- register int boolValue) /* Boolean used to initialize new object. */
+ int boolValue) /* Boolean used to initialize new object. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
- TclNewBooleanObj(objPtr, boolValue);
+ TclNewIntObj(objPtr, boolValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1795,23 +2006,25 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBooleanObj(
- register int boolValue, /* Boolean used to initialize new object. */
+ int boolValue, /* 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. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (boolValue? 1 : 0);
+ objPtr->internalRep.wideValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1820,11 +2033,9 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
- register int boolValue, /* 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. */
+ int boolValue, /* Boolean used to initialize new object. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBooleanObj(boolValue);
}
@@ -1851,15 +2062,16 @@ Tcl_DbNewBooleanObj(
#undef Tcl_SetBooleanObj
void
Tcl_SetBooleanObj(
- register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
- register int boolValue) /* Boolean used to set object's value. */
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ int boolValue) /* Boolean used to set object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetBooleanObj(objPtr, boolValue);
+ TclSetIntObj(objPtr, boolValue!=0);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1883,16 +2095,16 @@ Tcl_SetBooleanObj(
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr, /* The object from which to get boolean. */
- register int *boolPtr) /* Place to store resulting boolean. */
+ Tcl_Obj *objPtr, /* The object from which to get boolean. */
+ int *boolPtr) /* Place to store resulting boolean. */
{
do {
if (objPtr->typePtr == &tclIntType) {
- *boolPtr = (objPtr->internalRep.longValue != 0);
+ *boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
}
if (objPtr->typePtr == &tclBooleanType) {
- *boolPtr = (int) objPtr->internalRep.longValue;
+ *boolPtr = objPtr->internalRep.longValue != 0;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
@@ -1916,12 +2128,6 @@ Tcl_GetBooleanFromObj(
*boolPtr = 1;
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *boolPtr = (objPtr->internalRep.wideValue != 0);
- return TCL_OK;
- }
-#endif
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
@@ -1942,7 +2148,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.
*
*----------------------------------------------------------------------
*/
@@ -1950,7 +2161,7 @@ Tcl_GetBooleanFromObj(
int
TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr) /* The object to convert. */
+ Tcl_Obj *objPtr) /* The object to convert. */
{
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
@@ -1960,8 +2171,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 +2181,6 @@ TclSetBooleanFromAny(
goto badBoolean;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- goto badBoolean;
- }
-#endif
-
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
@@ -2003,11 +2207,12 @@ TclSetBooleanFromAny(
static int
ParseBoolean(
- register Tcl_Obj *objPtr) /* The object to parse/convert. */
+ 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)) {
/*
@@ -2059,25 +2264,25 @@ ParseBoolean(
/*
* Checking the 'y' is redundant, but makes the code clearer.
*/
- if (strncmp(lowerCase, "yes", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "yes", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'n':
- if (strncmp(lowerCase, "no", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "no", length) == 0) {
newBool = 0;
goto goodBoolean;
}
return TCL_ERROR;
case 't':
- if (strncmp(lowerCase, "true", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "true", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'f':
- if (strncmp(lowerCase, "false", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "false", length) == 0) {
newBool = 0;
goto goodBoolean;
}
@@ -2086,10 +2291,10 @@ ParseBoolean(
if (length < 2) {
return TCL_ERROR;
}
- if (strncmp(lowerCase, "on", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "on", length) == 0) {
newBool = 1;
goto goodBoolean;
- } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
+ } else if (strncmp(lowerCase, "off", length) == 0) {
newBool = 0;
goto goodBoolean;
}
@@ -2112,7 +2317,7 @@ ParseBoolean(
numericBoolean:
TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = newBool;
+ objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclIntType;
return TCL_OK;
}
@@ -2144,7 +2349,7 @@ ParseBoolean(
Tcl_Obj *
Tcl_NewDoubleObj(
- register double dblValue) /* Double used to initialize the object. */
+ double dblValue) /* Double used to initialize the object. */
{
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}
@@ -2153,9 +2358,9 @@ Tcl_NewDoubleObj(
Tcl_Obj *
Tcl_NewDoubleObj(
- register double dblValue) /* Double used to initialize the object. */
+ double dblValue) /* Double used to initialize the object. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
TclNewDoubleObj(objPtr, dblValue);
return objPtr;
@@ -2192,15 +2397,16 @@ Tcl_NewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
- register double dblValue, /* Double used to initialize the object. */
+ 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. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
@@ -2212,11 +2418,9 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
- register 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. */
+ double dblValue, /* Double used to initialize the object. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDoubleObj(dblValue);
}
@@ -2242,8 +2446,8 @@ Tcl_DbNewDoubleObj(
void
Tcl_SetDoubleObj(
- register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
- register double dblValue) /* Double used to set the object's value. */
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ double dblValue) /* Double used to set the object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj");
@@ -2275,8 +2479,8 @@ Tcl_SetDoubleObj(
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr, /* The object from which to get a double. */
- register double *dblPtr) /* Place to store resulting double. */
+ Tcl_Obj *objPtr, /* The object from which to get a double. */
+ double *dblPtr) /* Place to store resulting double. */
{
do {
if (objPtr->typePtr == &tclDoubleType) {
@@ -2293,22 +2497,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;
}
@@ -2336,7 +2534,7 @@ Tcl_GetDoubleFromObj(
static int
SetDoubleFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr) /* The object to convert. */
+ Tcl_Obj *objPtr) /* The object to convert. */
{
return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1,
NULL, 0);
@@ -2365,17 +2563,14 @@ SetDoubleFromAny(
static void
UpdateStringOfDouble(
- register Tcl_Obj *objPtr) /* Double obj with string rep to update. */
+ Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
- char buffer[TCL_DOUBLE_SPACE];
- register 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 = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
- objPtr->length = len;
+ Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
@@ -2408,28 +2603,30 @@ UpdateStringOfDouble(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewIntObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewIntObj(
- register int intValue) /* Int used to initialize the new object. */
+ int intValue) /* Int used to initialize the new object. */
{
- return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj((long)intValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewIntObj(
- register int intValue) /* Int used to initialize the new object. */
+ int intValue) /* Int used to initialize the new object. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
TclNewIntObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2448,12 +2645,12 @@ Tcl_NewIntObj(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
- register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
- register int intValue) /* Integer used to set object's value. */
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ int intValue) /* Integer used to set object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
@@ -2461,32 +2658,30 @@ Tcl_SetIntObj(
TclSetIntObj(objPtr, intValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
- * Retrieve the integer value of 'objPtr'.
- *
- * Value
+ * Attempt to return an int from the Tcl object "objPtr". If the object
+ * is not already an int, an attempt will be made to convert it to one.
*
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * An error occurred during conversion or the integral value can not
- * be represented as an integer (it might be too large). An error
- * message is left in the interpreter's result if 'interp' is not
- * NULL.
+ * Integer and long integer objects share the same "integer" type
+ * implementation. We store all integers as longs and Tcl_GetIntFromObj
+ * checks whether the current value of the long can be represented by an
+ * int.
*
- * Effect
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion or if the long integer held by the object can not be
+ * represented by an int, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
- * 'objPtr' is converted to an integer if necessary if it is not one
- * already. The conversion frees any previously-existing internal
- * representation.
+ * Side effects:
+ * If the object is not already an int, the conversion will free any old
+ * internal representation.
*
*----------------------------------------------------------------------
*/
@@ -2494,8 +2689,8 @@ Tcl_SetIntObj(
int
Tcl_GetIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr, /* The object from which to get a int. */
- register int *intPtr) /* Place to store resulting int. */
+ Tcl_Obj *objPtr, /* The object from which to get a int. */
+ int *intPtr) /* Place to store resulting int. */
{
#if (LONG_MAX == INT_MAX)
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
@@ -2505,7 +2700,7 @@ Tcl_GetIntFromObj(
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
- if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(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 as non-long integer";
@@ -2540,9 +2735,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);
}
/*
@@ -2566,17 +2760,27 @@ SetIntFromAny(
static void
UpdateStringOfInt(
- register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
+ Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
- char buffer[TCL_INTEGER_SPACE];
- register 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 = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
- objPtr->length = len;
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.longValue));
}
+#endif
/*
*----------------------------------------------------------------------
@@ -2608,30 +2812,32 @@ UpdateStringOfInt(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewLongObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewLongObj(
- register long longValue) /* Long integer used to initialize the
+ 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 */
Tcl_Obj *
Tcl_NewLongObj(
- register long longValue) /* Long integer used to initialize the
+ long longValue) /* Long integer used to initialize the
* new object. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
- TclNewLongObj(objPtr, longValue);
+ TclNewIntObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2665,23 +2871,26 @@ Tcl_NewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_DbNewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewLongObj(
- register long longValue, /* Long integer used to initialize the new
+ 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. */
{
- register Tcl_Obj *objPtr;
+ 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;
}
@@ -2690,16 +2899,15 @@ Tcl_DbNewLongObj(
Tcl_Obj *
Tcl_DbNewLongObj(
- register long longValue, /* Long integer used to initialize the new
+ 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 */
/*
*----------------------------------------------------------------------
@@ -2719,18 +2927,21 @@ Tcl_DbNewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
- register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
- register long longValue) /* Long integer used to initialize the
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ long longValue) /* Long integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
- TclSetLongObj(objPtr, longValue);
+ TclSetIntObj(objPtr, longValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2756,18 +2967,19 @@ Tcl_SetLongObj(
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr, /* The object from which to get a long. */
- register long *longPtr) /* Place to store resulting long. */
+ Tcl_Obj *objPtr, /* The object from which to get a long. */
+ 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
@@ -2776,9 +2988,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;
@@ -2801,28 +3013,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 (big.sign) {
+ if (value <= 1 + (unsigned long)LONG_MAX) {
*longPtr = - (long) value;
- } else {
+ return TCL_OK;
+ }
+ } else {
+ if (value <= (unsigned long)ULONG_MAX) {
*longPtr = (long) value;
+ return TCL_OK;
}
- return TCL_OK;
}
}
+ }
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
@@ -2839,49 +3053,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(
- register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
-{
- char buffer[TCL_INTEGER_SPACE+2];
- register unsigned len;
- register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
-
- /*
- * Note that sprintf 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.
- */
-
- sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
- len = strlen(buffer);
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
-}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -2913,7 +3084,7 @@ UpdateStringOfWideInt(
Tcl_Obj *
Tcl_NewWideIntObj(
- register Tcl_WideInt wideValue)
+ Tcl_WideInt wideValue)
/* Wide integer used to initialize the new
* object. */
{
@@ -2924,14 +3095,14 @@ Tcl_NewWideIntObj(
Tcl_Obj *
Tcl_NewWideIntObj(
- register Tcl_WideInt wideValue)
+ Tcl_WideInt wideValue)
/* Wide integer used to initialize the new
* object. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2972,7 +3143,7 @@ Tcl_NewWideIntObj(
Tcl_Obj *
Tcl_DbNewWideIntObj(
- register Tcl_WideInt wideValue,
+ Tcl_WideInt wideValue,
/* Wide integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
@@ -2980,10 +3151,10 @@ Tcl_DbNewWideIntObj(
int line) /* Line number in the source file; used for
* debugging. */
{
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
@@ -2991,13 +3162,11 @@ Tcl_DbNewWideIntObj(
Tcl_Obj *
Tcl_DbNewWideIntObj(
- register Tcl_WideInt wideValue,
+ 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);
}
@@ -3023,8 +3192,8 @@ Tcl_DbNewWideIntObj(
void
Tcl_SetWideIntObj(
- register Tcl_Obj *objPtr, /* Object w. internal rep to init. */
- register Tcl_WideInt wideValue)
+ Tcl_Obj *objPtr, /* Object w. internal rep to init. */
+ Tcl_WideInt wideValue)
/* Wide integer used to initialize the
* object's value. */
{
@@ -3032,19 +3201,7 @@ Tcl_SetWideIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
- if ((wideValue >= (Tcl_WideInt) LONG_MIN)
- && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
- TclSetLongObj(objPtr, (long) wideValue);
- } else {
-#ifndef TCL_WIDE_INT_IS_LONG
- TclSetWideIntObj(objPtr, wideValue);
-#else
- mp_int big;
-
- TclBNInitBignumFromWideInt(&big, wideValue);
- Tcl_SetBignumObj(objPtr, &big);
-#endif
- }
+ TclSetIntObj(objPtr, wideValue);
}
/*
@@ -3071,19 +3228,13 @@ Tcl_SetWideIntObj(
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr, /* Object from which to get a wide int. */
- register Tcl_WideInt *wideIntPtr)
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideInt *wideIntPtr)
/* 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) {
@@ -3102,25 +3253,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++;
- }
- if (big.sign) {
+ 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;
- } else {
+ return TCL_OK;
+ }
+ } else {
+ if (value <= (Tcl_WideUInt)WIDE_MAX) {
*wideIntPtr = (Tcl_WideInt) value;
+ return TCL_OK;
}
- return TCL_OK;
}
}
if (interp != NULL) {
@@ -3136,33 +3288,76 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
*
- * SetWideIntFromAny --
+ * TclGetWideBitsFromObj --
*
- * Attempts to force the internal representation for a Tcl object to
- * tclWideIntType, specifically.
+ * 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 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, double or bignum 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
+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. */
{
- Tcl_WideInt w;
- return Tcl_GetWideIntFromObj(interp, objPtr, &w);
+ 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 */
/*
*----------------------------------------------------------------------
@@ -3183,7 +3378,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);
@@ -3216,7 +3411,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");
}
@@ -3249,12 +3444,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) {
@@ -3269,13 +3462,14 @@ UpdateStringOfBignum(
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- stringVal = 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. */
+ (void) Tcl_InitStringRep(objPtr, NULL, size - 1);
}
/*
@@ -3299,14 +3493,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;
@@ -3337,7 +3531,7 @@ Tcl_NewBignumObj(
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBignumObj(
- mp_int *bignumValue,
+ void *bignumValue,
const char *file,
int line)
{
@@ -3350,9 +3544,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);
}
@@ -3391,37 +3585,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 TclFreeIntRep */
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(
@@ -3465,9 +3656,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);
}
/*
@@ -3500,9 +3691,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);
}
/*
@@ -3525,63 +3716,34 @@ 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 > (((~(Tcl_WideUInt)0) >> 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);
TclSetBignumIntRep(objPtr, bignumValue);
@@ -3608,8 +3770,9 @@ Tcl_SetBignumObj(
void
TclSetBignumIntRep(
Tcl_Obj *objPtr,
- mp_int *bignumValue)
+ void *big)
{
+ mp_int *bignumValue = (mp_int *)big;
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
@@ -3663,23 +3826,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;
@@ -3692,6 +3848,71 @@ TclGetNumberFromObj(
/*
*----------------------------------------------------------------------
*
+ * 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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DbIncrRefCount --
*
* This function is normally called when debugging: i.e., when
@@ -3710,23 +3931,23 @@ TclGetNumberFromObj(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
- register Tcl_Obj *objPtr, /* The object we are registering a reference
+ Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
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. */
{
-#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
@@ -3748,9 +3969,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 */
/*
*----------------------------------------------------------------------
@@ -3773,23 +4004,23 @@ Tcl_DbIncrRefCount(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
- register Tcl_Obj *objPtr, /* The object we are releasing a reference
+ Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
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. */
{
-#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
@@ -3811,12 +4042,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 */
/*
*----------------------------------------------------------------------
@@ -3841,11 +4084,16 @@ Tcl_DbDecrRefCount(
int
Tcl_DbIsShared(
- register Tcl_Obj *objPtr, /* The object to test for being shared. */
+ 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) {
@@ -3854,7 +4102,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
@@ -3913,7 +4161,7 @@ Tcl_DbIsShared(
void
Tcl_InitObjHashTable(
- register Tcl_HashTable *tablePtr)
+ Tcl_HashTable *tablePtr)
/* Pointer to table record, which is supplied
* by the caller. */
{
@@ -3939,11 +4187,11 @@ 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 = keyPtr;
- Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry));
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
+ Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
@@ -3974,10 +4222,10 @@ 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;
- register const char *p1, *p2;
- register size_t l1, l2;
+ const char *p1, *p2;
+ size_t l1, l2;
/*
* If the object pointers are the same then they match.
@@ -4058,15 +4306,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;
+ TCL_HASH_TYPE result = 0;
/*
* I tried a zillion different hash functions and asked many other people
@@ -4134,13 +4382,13 @@ Tcl_Command
Tcl_GetCommandFromObj(
Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
- register Tcl_Obj *objPtr) /* The object containing the command's name.
+ Tcl_Obj *objPtr) /* The object containing the command's name.
* If the name starts with "::", will be
* looked up in global namespace. Else, looked
* up first in the current namespace, then in
* global namespace. */
{
- register ResolvedCmdName *resPtr;
+ ResolvedCmdName *resPtr;
/*
* Get the internal representation, converting to a command type if
@@ -4161,15 +4409,14 @@ Tcl_GetCommandFromObj(
* to discard the old rep and create a new one.
*/
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
- register Command *cmdPtr = resPtr->cmdPtr;
+ 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)) {
- register Namespace *refNsPtr = (Namespace *)
+ Namespace *refNsPtr = (Namespace *)
TclGetCurrentNamespace(interp);
if ((resPtr->refNsPtr == NULL)
@@ -4186,11 +4433,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);
}
@@ -4214,57 +4461,78 @@ Tcl_GetCommandFromObj(
*----------------------------------------------------------------------
*/
-void
-TclSetCmdNameObj(
- Tcl_Interp *interp, /* Points to interpreter containing command
- * that should be cached in objPtr. */
- register 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;
- register ResolvedCmdName *resPtr;
- register 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 = ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
+ fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
- name = TclGetString(objPtr);
- if ((*name++ == ':') && (*name == ':')) {
+ /* NOTE: relying on NULL termination here. */
+ if ((name[0] == ':') && (name[1] == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * Fully qualified names always resolve to same thing. No need
+ * to record resolution context information.
*/
- resPtr->refNsPtr = NULL;
+ fillPtr->refNsPtr = NULL;
+ fillPtr->refNsId = 0; /* Will not be read */
+ fillPtr->refNsCmdEpoch = 0; /* Will not be read */
} else {
/*
- * Get the current namespace.
+ * Record current state of current namespace as the resolution
+ * context of this command name lookup.
*/
+ Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;
+
+ fillPtr->refNsPtr = currNsPtr;
+ fillPtr->refNsId = currNsPtr->nsId;
+ fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ if (resPtr == NULL) {
+ TclFreeIntRep(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);
}
/*
@@ -4290,18 +4558,17 @@ TclSetCmdNameObj(
static void
FreeCmdNameInternalRep(
- register Tcl_Obj *objPtr) /* CmdName object with internal
+ Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
- register 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
@@ -4313,7 +4580,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
- }
objPtr->typePtr = NULL;
}
@@ -4340,15 +4606,13 @@ FreeCmdNameInternalRep(
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- register 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;
}
@@ -4376,13 +4640,11 @@ DupCmdNameInternalRep(
static int
SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr) /* The object to convert. */
+ Tcl_Obj *objPtr) /* The object to convert. */
{
- Interp *iPtr = (Interp *) interp;
const char *name;
- register Command *cmdPtr;
- Namespace *currNsPtr;
- register ResolvedCmdName *resPtr;
+ Command *cmdPtr;
+ ResolvedCmdName *resPtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -4401,59 +4663,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 = 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) {
+ 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;
}
@@ -4475,12 +4709,11 @@ SetCmdNameFromAny(
int
Tcl_RepresentationCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
@@ -4494,36 +4727,20 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- sprintf(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 [represenation] 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) {
- sprintf(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..4383c62 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -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 b03ad41..da5c134 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -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
@@ -51,13 +51,14 @@ Tcl_SetPanicProc(
{
#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;
+ Tcl_InitSubsystems();
}
/*
@@ -141,8 +142,6 @@ Tcl_PanicVA(
*----------------------------------------------------------------------
*/
-/* ARGSUSED */
-
/*
* The following comment is here so that Coverity's static analizer 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 78f3a9e..7f32cfa 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -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:
@@ -167,6 +126,8 @@ 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);
@@ -236,19 +197,19 @@ Tcl_ParseCommand(
* NULL, then no error message is provided. */
const char *start, /* First character of string containing one or
* more Tcl commands. */
- register int numBytes, /* Total number of bytes in string. If < 0,
+ int numBytes, /* Total number of bytes in string. If < 0,
* the script consists of all bytes up to the
* first null character. */
int nested, /* Non-zero means this is a nested command:
* close bracket should be considered a
* command terminator. If zero, then close
* bracket has no special meaning. */
- register Tcl_Parse *parsePtr)
+ Tcl_Parse *parsePtr)
/* Structure to fill in with information about
* the parsed command; any previous
* information in the structure is ignored. */
{
- register const char *src; /* Points to current character in the
+ const char *src; /* Points to current character in the
* command. */
char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
@@ -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;
}
/*
@@ -684,14 +622,14 @@ TclIsBareword(
static int
ParseWhiteSpace(
const char *src, /* First character to parse. */
- register int numBytes, /* Max number of bytes to scan. */
+ int numBytes, /* Max number of bytes to scan. */
int *incompletePtr, /* Set this boolean memory to true if parsing
* indicates an incomplete command. */
char *typePtr) /* Points to location to store character type
* of character that ends run of whitespace */
{
- register char type = TYPE_NORMAL;
- register const char *p = src;
+ char type = TYPE_NORMAL;
+ const char *p = src;
while (1) {
while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
@@ -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);
+}
/*
*----------------------------------------------------------------------
@@ -784,7 +731,7 @@ ParseHex(
* conversion is to be written. */
{
int result = 0;
- register const char *p = src;
+ const char *p = src;
while (numBytes--) {
unsigned char digit = UCHAR(*p);
@@ -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. */
{
- register const char *p = src+1;
+ const char *p = src+1;
+ Tcl_UniChar unichar = 0;
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,7 +887,7 @@ TclParseBackslash(
* No hexdigits -> This is just "U".
*/
result = 'U';
- } else if ((result & ~0x7FF) == 0xD800) {
+ } else if ((result | 0x7FF) == 0xDFFF) {
/* Upper or lower surrogate, not allowed in this syntax. */
result = 0xFFFD;
}
@@ -990,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 = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
- char utfBytes[8];
+ char utfBytes[4];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
- count = TclUtfToUCS4(utfBytes, &result) + 1;
+ count = TclUtfToUniChar(utfBytes, &unichar) + 1;
}
+ result = unichar;
break;
}
@@ -1006,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;
}
/*
@@ -1035,23 +981,18 @@ TclParseBackslash(
static int
ParseComment(
const char *src, /* First character to parse. */
- register int numBytes, /* Max number of bytes to scan. */
+ int numBytes, /* Max number of bytes to scan. */
Tcl_Parse *parsePtr) /* Information about parse in progress.
* Updated if parsing indicates an incomplete
* command. */
{
- register const char *p = src;
+ 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;
@@ -1060,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);
}
@@ -1119,8 +1053,8 @@ ParseComment(
static int
ParseTokens(
- register const char *src, /* First character to parse. */
- register int numBytes, /* Max number of bytes to scan. */
+ const char *src, /* First character to parse. */
+ int numBytes, /* Max number of bytes to scan. */
int mask, /* Specifies when to stop parsing. The parse
* stops at the first unquoted character whose
* CHAR_TYPE contains any of the bits in
@@ -1211,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;
@@ -1398,7 +1332,7 @@ Tcl_ParseVarName(
* NULL, then no error message is provided. */
const char *start, /* Start of variable substitution string.
* First character must be "$". */
- register int numBytes, /* Total number of bytes in string. If < 0,
+ int numBytes, /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr, /* Structure to fill in with information about
@@ -1409,7 +1343,7 @@ Tcl_ParseVarName(
* reinitialize it. */
{
Tcl_Token *tokenPtr;
- register const char *src;
+ const char *src;
int varIndex;
unsigned array;
@@ -1590,15 +1524,15 @@ Tcl_ParseVarName(
const char *
Tcl_ParseVar(
Tcl_Interp *interp, /* Context for looking up variable. */
- register const char *start, /* Start of variable substitution. First
+ const char *start, /* Start of variable substitution. First
* character must be "$". */
const char **termPtr) /* If non-NULL, points to word to fill in with
* character just after last one in the
* variable specifier. */
{
- register Tcl_Obj *objPtr;
+ 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);
@@ -1675,10 +1609,10 @@ Tcl_ParseBraces(
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
- register int numBytes, /* Total number of bytes in string. If < 0,
+ int numBytes, /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
- register Tcl_Parse *parsePtr,
+ Tcl_Parse *parsePtr,
/* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
@@ -1691,7 +1625,7 @@ Tcl_ParseBraces(
* successful. */
{
Tcl_Token *tokenPtr;
- register const char *src;
+ const char *src;
int startIndex, level, length;
if (numBytes < 0 && start) {
@@ -1816,7 +1750,7 @@ Tcl_ParseBraces(
*/
{
- register int openBrace = 0;
+ int openBrace = 0;
while (--src > start) {
switch (*src) {
@@ -1876,10 +1810,10 @@ Tcl_ParseQuotedString(
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
- register int numBytes, /* Total number of bytes in string. If < 0,
+ int numBytes, /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
- register Tcl_Parse *parsePtr,
+ Tcl_Parse *parsePtr,
/* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
@@ -2077,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 ==
@@ -2219,7 +2153,7 @@ TclSubstTokens(
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
- clPosition = ckalloc(maxNumCL * sizeof(int));
+ clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
@@ -2228,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:
@@ -2264,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;
@@ -2540,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 c5b1ef6..32b2961 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -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 *) (TclFetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1))
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((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 (TclHasIntRep(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.
*/
@@ -864,6 +843,7 @@ TclJoinPath(
if (elements == 2) {
Tcl_Obj *elt = objv[0];
+ Tcl_ObjIntRep *eltIr = TclFetchIntRep(elt, &fsPathType);
/*
* This is a special case where we can be much more efficient, where
@@ -874,10 +854,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];
@@ -890,7 +870,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 '/'.
@@ -961,7 +941,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 :
@@ -1057,10 +1037,8 @@ TclJoinPath(
noQuickReturn:
if (res == NULL) {
res = Tcl_NewObj();
- 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
@@ -1093,7 +1071,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)) {
@@ -1105,7 +1083,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));
@@ -1171,39 +1149,16 @@ Tcl_FSConvertToPathType(
* path.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasIntRep(pathPtr, &fsPathType)) {
if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
return TCL_OK;
}
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreIntRep(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.
- */
}
/*
@@ -1318,7 +1273,7 @@ TclNewFSPathObj(
}
pathPtr = Tcl_NewObj();
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* Set up the path.
@@ -1335,9 +1290,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 "."
@@ -1399,7 +1352,7 @@ AppendPath(
* intrep 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 {
@@ -1432,14 +1385,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_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
@@ -1458,7 +1412,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
@@ -1478,7 +1432,7 @@ TclFSMakePathRelative(
}
break;
}
- tempStr = Tcl_GetStringFromObj(pathPtr, &len);
+ tempStr = TclGetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
@@ -1502,36 +1456,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 (TclHasIntRep(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.
@@ -1539,11 +1473,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;
@@ -1552,7 +1482,6 @@ MakePathFromNormalized(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -1562,7 +1491,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
@@ -1603,25 +1532,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_StoreIntRep(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;
@@ -1629,7 +1545,6 @@ Tcl_FSNewNativePath(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return pathPtr;
}
@@ -1639,16 +1554,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.
*
*---------------------------------------------------------------------------
*/
@@ -1666,7 +1583,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
@@ -1676,29 +1598,23 @@ Tcl_FSGetTranslatedPath(
Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
srcFsPathPtr->cwdPtr);
+ Tcl_ObjIntRep *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 = TclFetchIntRep(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 {
/*
@@ -1742,10 +1658,10 @@ 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, (size_t) len+1);
+ memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
}
@@ -1799,11 +1715,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 {
@@ -1816,7 +1730,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. */
@@ -1853,7 +1767,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
@@ -1868,10 +1782,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
} else {
@@ -1880,10 +1790,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
@@ -1895,10 +1801,8 @@ Tcl_FSGetNormalizedPath(
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
@@ -1909,7 +1813,7 @@ Tcl_FSGetNormalizedPath(
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
- (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
+ (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
/*
@@ -1924,10 +1828,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.
*/
@@ -1974,7 +1877,6 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
- pureNormalized = 0;
Tcl_DecrRefCount(absolutePath);
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
@@ -1994,7 +1896,6 @@ Tcl_FSGetNormalizedPath(
if (absolutePath == NULL) {
return NULL;
}
- pureNormalized = 0;
#endif /* _WIN32 */
}
}
@@ -2003,35 +1904,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
@@ -2052,19 +1930,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.
*
*---------------------------------------------------------------------------
*/
@@ -2082,49 +1964,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) {
@@ -2145,7 +2014,7 @@ Tcl_FSGetInternalRep(
return NULL;
}
- nativePathPtr = proc(pathPtr);
+ nativePathPtr = (char *)proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
@@ -2159,15 +2028,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.
*
*---------------------------------------------------------------------------
*/
@@ -2179,37 +2048,31 @@ TclFSEnsureEpochOk(
{
FsPath *srcFsPathPtr;
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (!TclHasIntRep(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_StoreIntRep(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;
@@ -2243,7 +2106,7 @@ TclFSSetPathDetails(
* Make sure pathPtr is of the correct type.
*/
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (!TclHasIntRep(pathPtr, &fsPathType)) {
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return;
}
@@ -2317,11 +2180,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.
@@ -2340,9 +2204,9 @@ SetFsPathFromAny(
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
- char *name;
+ const char *name;
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
@@ -2360,7 +2224,7 @@ SetFsPathFromAny(
* cmdAH.test exercise most of the code).
*/
- name = Tcl_GetStringFromObj(pathPtr, &len);
+ name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
@@ -2405,7 +2269,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&dirString);
} else {
/*
- * We have a user name '~user'
+ * There is a '~user'
*/
const char *expandedUser;
@@ -2482,29 +2346,23 @@ 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) {
+ 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;
}
@@ -2527,6 +2385,7 @@ FreeFsPathInternalRep(
}
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
}
if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
@@ -2539,7 +2398,6 @@ FreeFsPathInternalRep(
}
ckfree(fsPathPtr);
- pathPtr->typePtr = NULL;
}
static void
@@ -2548,28 +2406,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;
@@ -2595,8 +2443,6 @@ DupFsPathInternalRep(
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
-
- copyPtr->typePtr = &tclFsPathType;
}
/*
@@ -2617,7 +2463,7 @@ DupFsPathInternalRep(
static void
UpdateStringOfFsPath(
- register Tcl_Obj *pathPtr) /* path obj with string rep to update. */
+ Tcl_Obj *pathPtr) /* path obj with string rep to update. */
{
FsPath *fsPathPtr = PATHOBJ(pathPtr);
int cwdLen;
@@ -2628,11 +2474,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);
}
@@ -2660,7 +2510,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
@@ -2669,7 +2519,7 @@ TclNativePathInFilesystem(
* semantics of Tcl (at present anyway), so we have to abide by them here.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasIntRep(pathPtr, &fsPathType)) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/*
* We reject the empty path "".
@@ -2684,13 +2534,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 "".
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index bd49bec..8d5c0c7 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec,
static TclFile
FileForRedirect(
- Tcl_Interp *interp, /* Intepreter to use for error reporting. */
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. */
const char *spec, /* Points to character just after redirection
* character. */
int atOK, /* Non-zero means that '@' notation can be
@@ -183,12 +183,12 @@ Tcl_DetachPids(
* array pointed to by pidPtr. */
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
- register Detached *detPtr;
+ Detached *detPtr;
int i;
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;
@@ -219,15 +219,15 @@ Tcl_DetachPids(
void
Tcl_ReapDetachedProcs(void)
{
- register Detached *detPtr;
+ 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;
- sprintf(msg1, "%lu", resolvedPid);
- if (WIFEXITED(waitStatus)) {
+ if (waitStatus == TCL_PROCESS_EXITED) {
if (interp != NULL) {
- sprintf(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);
objPtr = Tcl_NewObj();
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 06d6ade..b39224e 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -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[1];
+} 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) {
+ list = Tcl_NewObj();
+ 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(sizeof(PkgName) + 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);
@@ -738,14 +925,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) {
@@ -756,7 +942,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;
}
@@ -817,7 +1004,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
@@ -865,31 +1052,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
+ 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,16 +1099,44 @@ TclNRPackageObjCmd(
return TCL_ERROR;
}
switch ((enum pkgOptions) 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);
@@ -932,6 +1146,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);
@@ -957,11 +1175,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) {
@@ -974,7 +1192,7 @@ TclNRPackageObjCmd(
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
- if (res == 0){
+ if (res == 0) {
if (objc == 4) {
ckfree(argv3i);
Tcl_SetObjResult(interp,
@@ -982,6 +1200,10 @@ TclNRPackageObjCmd(
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
break;
}
}
@@ -991,8 +1213,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;
@@ -1002,8 +1225,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:
@@ -1017,10 +1244,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);
@@ -1046,7 +1273,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;
}
@@ -1081,7 +1308,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);
}
@@ -1133,12 +1360,16 @@ TclNRPackageObjCmd(
Tcl_ListObjAppendElement(interp, objvListPtr, ov);
Tcl_ListObjGetElements(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 {
int i, newobjc = objc-3;
Tcl_Obj *const *newobjv = objv + 3;
+
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
@@ -1146,17 +1377,20 @@ TclNRPackageObjCmd(
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]));
}
Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
- Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL);
+ Tcl_NRAddCallback(interp,
+ TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL);
+ Tcl_NRAddCallback(interp,
+ PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
+ newObjvPtr, NULL);
return TCL_OK;
}
break;
@@ -1172,11 +1406,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?");
@@ -1260,7 +1494,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,
@@ -1299,9 +1533,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;
}
@@ -1335,13 +1573,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;
}
@@ -1365,7 +1603,7 @@ FindPackage(
void
TclFreePackageInfo(
- Interp *iPtr) /* Interpereter that is being deleted. */
+ Interp *iPtr) /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
@@ -1374,7 +1612,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);
}
@@ -1383,6 +1621,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);
@@ -1429,7 +1671,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;
/*
@@ -1756,7 +1998,7 @@ CheckRequirement(
char *dash = NULL, *buf;
- dash = strchr(string, '-');
+ dash = (char *)strchr(string, '-');
if (dash == NULL) {
/*
* No dash found, has to be a simple version.
@@ -1827,7 +2069,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)) {
@@ -1944,7 +2186,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
@@ -2040,7 +2282,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 466d535..96b6962 100644
--- a/generic/tclPkgConfig.c
+++ b/generic/tclPkgConfig.c
@@ -40,7 +40,7 @@
* configuration information.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
# define CFG_THREADED "1"
#else
# define CFG_THREADED "0"
@@ -105,6 +105,8 @@ static Tcl_Config const cfg[] = {
{"scriptdir,runtime", CFG_RUNTIME_SCRDIR},
{"includedir,runtime", CFG_RUNTIME_INCDIR},
{"docdir,runtime", CFG_RUNTIME_DOCDIR},
+ {"dllfile,runtime", CFG_RUNTIME_DLLFILE},
+ {"zipfile,runtime", CFG_RUNTIME_ZIPFILE},
/* Installation paths to various stuff */
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index 974bafa..4b06148 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -122,6 +122,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/tclPreserve.c b/generic/tclPreserve.c
index cca13e8..d60ebec 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -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 4600382..0d67c37 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -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,6 +67,22 @@ const Tcl_ObjType tclProcBodyType = {
* should panic instead. */
};
+#define ProcSetIntRep(objPtr, procPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (procPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
+ } while (0)
+
+#define ProcGetIntRep(objPtr, procPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
+ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* The [upvar]/[uplevel] level reference type. Uses the longValue field
* to remember the integer value of a parsed #<integer> format.
@@ -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 LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = (nsObjPtr); \
+ Tcl_IncrRefCount((nsObjPtr)); \
+ Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
+ } while (0)
+
+#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((objPtr), &lambdaType); \
+ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
+ (nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -114,10 +148,9 @@ const Tcl_ObjType tclLambdaType = {
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ProcObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -163,8 +196,8 @@ Tcl_ProcObjCmd(
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
- &procPtr) != TCL_OK) {
+ if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
+ objv[3], &procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
@@ -200,7 +233,6 @@ Tcl_ProcObjCmd(
CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
-
if (contextPtr->type == TCL_LOCATION_BC) {
/*
* Retrieve source information from the bytecode, if possible. If
@@ -246,7 +278,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
@@ -255,7 +287,7 @@ Tcl_ProcObjCmd(
* is able to trigger this situation.
*/
- CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr);
+ CmdFrame *cfOldPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
@@ -295,7 +327,7 @@ Tcl_ProcObjCmd(
* of all procs whose argument list is just _args_
*/
- if (objv[3]->typePtr == &tclProcBodyType) {
+ if (TclHasIntRep(objv[3], &tclProcBodyType)) {
goto done;
}
@@ -320,7 +352,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;
}
@@ -363,7 +395,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. */
@@ -371,13 +403,14 @@ TclCreateProc(
{
Interp *iPtr = (Interp *) interp;
- Proc *procPtr;
+ Proc *procPtr = NULL;
int i, result, numArgs;
CompiledLocal *localPtr = NULL;
Tcl_Obj **argArray;
int precompiled = 0;
- if (bodyPtr->typePtr == &tclProcBodyType) {
+ ProcGetIntRep(bodyPtr, procPtr);
+ if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
* compiled, and it is not shared with anyone else, so it's OK not to
@@ -390,7 +423,6 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -452,7 +484,7 @@ TclCreateProc(
* in the Proc.
*/
- result = Tcl_ListObjGetElements(interp, argsPtr, &numArgs, &argArray);
+ result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
if (result != TCL_OK) {
goto procError;
}
@@ -474,7 +506,7 @@ TclCreateProc(
}
for (i = 0; i < numArgs; i++) {
- const char *argname, *p, *last;
+ const char *argname, *argnamei, *argnamelast;
int fieldCount, nameLength;
Tcl_Obj **fieldValues;
@@ -505,15 +537,17 @@ TclCreateProc(
goto procError;
}
+ argname = Tcl_GetStringFromObj(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])));
@@ -521,7 +555,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]);
@@ -531,7 +565,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei++;
}
if (precompiled) {
@@ -565,11 +599,10 @@ TclCreateProc(
*/
if (localPtr->defValuePtr != NULL) {
- int tmpLength, valueLength;
- const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
- &tmpLength);
- const char *value = TclGetStringFromObj(fieldValues[1],
- &valueLength);
+ const char *tmpPtr = TclGetString(localPtr->defValuePtr);
+ size_t tmpLength = localPtr->defValuePtr->length;
+ const char *value = TclGetString(fieldValues[1]);
+ size_t valueLength = fieldValues[1]->length;
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0
@@ -599,8 +632,7 @@ TclCreateProc(
* local variables for the argument.
*/
- localPtr = (CompiledLocal *)ckalloc(
- TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
+ localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + fieldValues[0]->length +1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -684,56 +716,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);
+ TclFreeIntRep(&obj);
+ return result;
}
/*
@@ -770,7 +761,9 @@ TclObjGetFrame(
{
Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
+ const Tcl_ObjIntRep *irPtr;
const char *name = NULL;
+ Tcl_WideInt w;
/*
* Parse object to figure out which level number to go to.
@@ -786,25 +779,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 = TclFetchIntRep(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_ObjIntRep ir;
+
+ ir.wideValue = level;
+ Tcl_StoreIntRep(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.
@@ -813,11 +815,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;
@@ -828,11 +835,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;
@@ -861,7 +868,7 @@ Uplevel_Callback(
Tcl_Interp *interp,
int result)
{
- CallFrame *savedVarFramePtr = data[0];
+ CallFrame *savedVarFramePtr = (CallFrame *)data[0];
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
@@ -876,20 +883,19 @@ Uplevel_Callback(
return result;
}
- /* ARGSUSED */
int
Tcl_UplevelObjCmd(
- 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, TclNRUplevelObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv);
}
int
TclNRUplevelObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1024,7 +1030,7 @@ TclIsProc(
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->deleteProc == TclProcDeleteProc) {
- return cmdPtr->objClientData;
+ return (Proc *)cmdPtr->objClientData;
}
return NULL;
}
@@ -1046,7 +1052,7 @@ ProcWrongNumArgs(
numArgs = framePtr->procPtr->numArgs;
desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
- (int) sizeof(Tcl_Obj *) * (numArgs+1));
+ sizeof(Tcl_Obj *) * (numArgs+1));
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
@@ -1060,7 +1066,7 @@ ProcWrongNumArgs(
Tcl_IncrRefCount(desiredObjs[0]);
if (localCt > 0) {
- Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt);
+ Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
for (i=1 ; i<=numArgs ; i++, defPtr++) {
Tcl_Obj *argObj;
@@ -1123,10 +1129,10 @@ TclInitCompiledLocals(
ByteCode *codePtr;
bodyPtr = framePtr->procPtr->bodyPtr;
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ ByteCodeGetIntRep(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) {
@@ -1289,7 +1295,7 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
@@ -1297,7 +1303,9 @@ InitLocalCache(
Var *varPtr;
LocalCache *localCachePtr;
CompiledLocal *localPtr;
- int new;
+ int isNew;
+
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
/*
* Cache the names and initial values of local variables; store the
@@ -1305,7 +1313,7 @@ InitLocalCache(
* for future calls.
*/
- localCachePtr = ckalloc(sizeof(LocalCache)
+ localCachePtr = (LocalCache *)ckalloc(sizeof(LocalCache)
+ (localCt - 1) * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
@@ -1318,7 +1326,7 @@ InitLocalCache(
} else {
*namePtr = TclCreateLiteral(iPtr, localPtr->name,
localPtr->nameLength, /* hash */ (unsigned int) -1,
- &new, /* nsPtr */ NULL, 0, NULL);
+ &isNew, /* nsPtr */ NULL, 0, NULL);
Tcl_IncrRefCount(*namePtr);
}
@@ -1360,17 +1368,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;
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Make sure that the local cache of variable names and initial values has
* been initialised properly .
@@ -1393,7 +1402,7 @@ InitArgsAndLocals(
* parameters.
*/
- varPtr = TclStackAlloc(interp, localCt * sizeof(Var));
+ varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var));
framePtr->compiledLocals = varPtr;
framePtr->numCompiledLocals = localCt;
@@ -1531,7 +1540,7 @@ TclPushProcCallFrame(
int isLambda) /* 1 if this is a call by ApplyObjCmd: it
* needs special rules for error msg */
{
- Proc *procPtr = clientData;
+ Proc *procPtr = (Proc *)clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
int result;
@@ -1545,7 +1554,8 @@ TclPushProcCallFrame(
* local variables are found while compiling.
*/
- if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
Interp *iPtr = (Interp *) interp;
/*
@@ -1557,7 +1567,6 @@ TclPushProcCallFrame(
* commands and/or resolver changes are considered).
*/
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1681,7 +1690,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. */
@@ -1755,7 +1764,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1771,7 +1780,7 @@ InterpProcNR2(
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
- Tcl_Obj *procNameObj = data[0];
+ Tcl_Obj *procNameObj = (Tcl_Obj *)data[0];
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
@@ -1887,7 +1896,9 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+
+ ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1903,7 +1914,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)
@@ -1922,11 +1933,12 @@ TclProcCompileProc(
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
- TclFreeIntRep(bodyPtr);
+ Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL);
+ codePtr = NULL;
}
}
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ if (codePtr == NULL) {
Tcl_HashEntry *hePtr;
#ifdef TCL_COMPILE_DEBUG
@@ -1945,6 +1957,9 @@ TclProcCompileProc(
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
+#else
+ (void)description;
+ (void)procName;
#endif
/*
@@ -2006,7 +2021,7 @@ TclProcCompileProc(
*/
iPtr->invokeWord = 0;
- iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
+ iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL;
TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
@@ -2048,7 +2063,7 @@ MakeProcError(
* messages and trace information. */
{
int overflow, limit = 60, nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+ const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
@@ -2081,7 +2096,7 @@ void
TclProcDeleteProc(
ClientData clientData) /* Procedure to be deleted. */
{
- Proc *procPtr = clientData;
+ Proc *procPtr = (Proc *)clientData;
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
@@ -2156,7 +2171,7 @@ TclProcCleanupProc(
return;
}
- cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);
+ cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfPtr) {
if (cfPtr->type == TCL_LOCATION_SOURCE) {
@@ -2275,10 +2290,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
- objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
-
- procPtr->refCount++;
+ ProcSetIntRep(objPtr, procPtr);
}
return objPtr;
@@ -2306,11 +2318,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+ ProcGetIntRep(srcPtr, procPtr);
- dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- procPtr->refCount++;
+ ProcSetIntRep(dupPtr, procPtr);
}
/*
@@ -2336,7 +2347,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+
+ ProcGetIntRep(objPtr, procPtr);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
@@ -2362,15 +2375,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;
+ LambdaGetIntRep(srcPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
procPtr->refCount++;
- Tcl_IncrRefCount(nsObjPtr);
- copyPtr->typePtr = &tclLambdaType;
+
+ LambdaSetIntRep(copyPtr, procPtr, nsObjPtr);
}
static void
@@ -2378,14 +2391,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;
+
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
- if (procPtr->refCount-- == 1) {
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
- objPtr->typePtr = NULL;
}
static int
@@ -2406,7 +2421,7 @@ 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);
@@ -2463,7 +2478,7 @@ SetLambdaFromAny(
*/
if (iPtr->cmdFramePtr) {
- CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
if (contextPtr->type == TCL_LOCATION_BC) {
@@ -2499,12 +2514,12 @@ SetLambdaFromAny(
* location (line of 2nd list element).
*/
- cfPtr = ckalloc(sizeof(CmdFrame));
+ cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = ckalloc(sizeof(int));
+ cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = buf[1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -2547,21 +2562,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;
+ LambdaSetIntRep(objPtr, procPtr, nsObjPtr);
return TCL_OK;
}
+
+Proc *
+TclGetLambdaFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Obj **nsObjPtrPtr)
+{
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
+
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
+
+ if (procPtr == NULL) {
+ if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
+ }
+
+ assert(procPtr != NULL);
+ if (procPtr->iPtr != (Interp *)interp) {
+ return NULL;
+ }
+
+ *nsObjPtrPtr = nsObjPtr;
+ return procPtr;
+}
/*
*----------------------------------------------------------------------
@@ -2582,22 +2618,21 @@ SetLambdaFromAny(
int
Tcl_ApplyObjCmd(
- 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, TclNRApplyObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv);
}
int
TclNRApplyObjCmd(
- 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;
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result;
@@ -2615,54 +2650,23 @@ TclNRApplyObjCmd(
*/
lambdaPtr = objv[1];
- if (lambdaPtr->typePtr == &tclLambdaType) {
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
- }
-
-#define JOE_EXTENSION 0
-/*
- * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
- * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
- * the code. (MS)
- */
+ procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr);
-#if JOE_EXTENSION
- else {
- /*
- * Joe English's suggestion to allow cmdNames to function as lambdas.
- */
-
- Tcl_Obj *elemPtr;
- int numElem;
-
- if ((lambdaPtr->typePtr == &tclCmdNameType) ||
- (TclListObjGetElements(interp, lambdaPtr, &numElem,
- &elemPtr) == TCL_OK && numElem == 1)) {
- return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
- }
- }
-#endif
-
- 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;
}
- extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData));
+ extraPtr = (ApplyExtraData *)TclStackAlloc(interp, sizeof(ApplyExtraData));
memset(&extraPtr->cmd, 0, sizeof(Command));
procPtr->cmdPtr = &extraPtr->cmd;
extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
@@ -2697,7 +2701,7 @@ ApplyNR2(
Tcl_Interp *interp,
int result)
{
- ApplyExtraData *extraPtr = data[0];
+ ApplyExtraData *extraPtr = (ApplyExtraData *)data[0];
TclStackFree(interp, extraPtr);
return result;
@@ -2729,7 +2733,7 @@ MakeLambdaError(
* messages and trace information. */
{
int overflow, limit = 60, nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+ const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
new file mode 100644
index 0000000..5bf0af8
--- /dev/null
+++ b/generic/tclProcess.c
@@ -0,0 +1,958 @@
+/*
+ * tclProcess.c --
+ *
+ * This file implements the "tcl::process" ensemble for subprocess
+ * management as defined by TIP #462.
+ *
+ * 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.
+ */
+
+#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 int ProcessListObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int ProcessStatusObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int ProcessPurgeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int ProcessAutopurgeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ errorStrings[1] = Tcl_NewIntObj(resolvedPid);
+ errorStrings[2] = Tcl_NewIntObj(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);
+ errorStrings[1] = Tcl_NewIntObj(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);
+ errorStrings[1] = Tcl_NewIntObj(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);
+ errorStrings[4] = Tcl_NewIntObj(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_NewIntObj(TCL_OK);
+ }
+
+ /*
+ * Abnormal exit, return {TCL_ERROR msg error}
+ */
+
+ resultObjs[0] = Tcl_NewIntObj(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(ClientData),
+ 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_NewIntObj(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(ClientData),
+ 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 switches {
+ 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 switches) 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_NewIntObj(info->resolvedPid),
+ BuildProcessStatusObj(info));
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ } else {
+ /*
+ * Only return statuses of provided processes.
+ */
+
+ result = Tcl_ListObjGetElements(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_NewIntObj(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(ClientData),
+ 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 = Tcl_ListObjGetElements(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(ClientData),
+ 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 19ff8fd..8b88423 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -13,6 +13,7 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include <assert.h>
/*
*----------------------------------------------------------------------
@@ -64,7 +65,7 @@
#define NUM_REGEXPS 30
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
* expression patterns. NULL means that this
@@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = {
NULL, /* updateStringProc */
SetRegexpFromAny /* setFromAnyProc */
};
+
+#define RegexpSetIntRep(objPtr, rePtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ (rePtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (rePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \
+ } while (0)
+
+#define RegexpGetIntRep(objPtr, rePtr) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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 < 0) {
+ } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) {
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
@@ -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;
@@ -510,9 +528,9 @@ Tcl_RegExpMatchObj(
*/
if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
- TCL_REG_ADVANCED | TCL_REG_NOSUB))
+ TCL_REG_ADVANCED | TCL_REG_NOSUB))
&& !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
- return -1;
+ return -1;
}
return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
0 /* nmatches */, 0 /* flags */);
@@ -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.
- */
+ RegexpGetIntRep(objPtr, regexpPtr);
- regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
-
- 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;
+ RegexpSetIntRep(objPtr, regexpPtr);
}
return (Tcl_RegExp) regexpPtr;
}
@@ -679,7 +678,7 @@ TclRegAbout(
resultObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewIntObj((int) regexpPtr->re.re_nsub));
+ Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub));
/*
* 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;
+
+ RegexpGetIntRep(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;
+
+ RegexpGetIntRep(srcPtr, regexpPtr);
+
+ assert(regexpPtr != NULL);
- regexpPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->typePtr = &tclRegexpType;
+ RegexpSetIntRep(copyPtr, regexpPtr);
}
/*
@@ -912,7 +916,7 @@ CompileRegexp(
* This is a new expression, so compile it and add it to the cache.
*/
- regexpPtr = ckalloc(sizeof(TclRegexp));
+ regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
@@ -967,7 +971,7 @@ CompileRegexp(
*/
regexpPtr->matches =
- ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
+ (regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
@@ -993,8 +997,8 @@ CompileRegexp(
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
- tsdPtr->patterns[0] = ckalloc(length + 1);
- memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1);
+ tsdPtr->patterns[0] = (char *)ckalloc(length + 1);
+ memcpy(tsdPtr->patterns[0], string, length + 1);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
@@ -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..ca53014 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -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 caad71e..baecf46 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -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(
@@ -411,14 +414,14 @@ void
Tcl_SetResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return value. */
- register char *result, /* Value to be returned. If NULL, the result
+ char *result, /* Value to be returned. If NULL, the result
* is set to an empty string. */
Tcl_FreeProc *freeProc) /* Gives information about the string:
* TCL_STATIC, TCL_VOLATILE, or the address of
* a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
- register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
+ Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
if (result == NULL) {
@@ -429,13 +432,13 @@ 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;
iPtr->freeProc = 0;
}
- memcpy(iPtr->result, result, (unsigned) length+1);
+ memcpy(iPtr->result, result, length+1);
} else {
iPtr->result = (char *) result;
iPtr->freeProc = freeProc;
@@ -481,21 +484,21 @@ Tcl_SetResult(
const char *
Tcl_GetStringResult(
- register Tcl_Interp *interp)/* Interpreter whose result to return. */
+ Tcl_Interp *interp)/* Interpreter whose result to return. */
{
+ 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;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -520,11 +523,11 @@ void
Tcl_SetObjResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return object value. */
- register Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj
+ Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj
* result is made an empty string object. */
{
- register Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
@@ -536,6 +539,7 @@ Tcl_SetObjResult(
TclDecrRefCount(oldObjResult);
+#ifndef TCL_NO_DEPRECATED
/*
* Reset the string result since we just set the result object.
*/
@@ -550,6 +554,7 @@ Tcl_SetObjResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif
}
/*
@@ -577,7 +582,8 @@ Tcl_Obj *
Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
+#ifndef TCL_NO_DEPRECATED
Tcl_Obj *objResultPtr;
int length;
@@ -604,6 +610,7 @@ Tcl_GetObjResult(
iPtr->result = iPtr->resultSpace;
iPtr->result[0] = 0;
}
+#endif /* !TCL_NO_DEPRECATED */
return iPtr->objResultPtr;
}
@@ -640,23 +647,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 +712,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 +779,7 @@ Tcl_AppendElement(
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
+#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -795,6 +801,7 @@ Tcl_AppendElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static void
SetupAppendBuffer(
Interp *iPtr, /* Interpreter whose result is being set up. */
@@ -834,19 +841,19 @@ SetupAppendBuffer(
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
- char *new;
+ char *newSpace;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
- new = ckalloc(totalSpace);
- strcpy(new, iPtr->result);
+ newSpace = (char *)ckalloc(totalSpace);
+ strcpy(newSpace, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
- iPtr->appendResult = new;
+ iPtr->appendResult = newSpace;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
@@ -880,9 +887,9 @@ SetupAppendBuffer(
void
Tcl_FreeResult(
- register Tcl_Interp *interp)/* Interpreter for which to free result. */
+ Tcl_Interp *interp)/* Interpreter for which to free result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
@@ -895,7 +902,8 @@ Tcl_FreeResult(
ResetObjResult(iPtr);
}
-
+#endif /* !TCL_NO_DEPRECATED */
+
/*
*----------------------------------------------------------------------
*
@@ -917,11 +925,12 @@ Tcl_FreeResult(
void
Tcl_ResetResult(
- register Tcl_Interp *interp)/* Interpreter for which to clear result. */
+ Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
+#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -932,6 +941,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) {
@@ -980,10 +990,10 @@ Tcl_ResetResult(
static void
ResetObjResult(
- register Interp *iPtr) /* Points to the interpreter whose result
+ Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
- register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
+ Tcl_Obj *objResultPtr = iPtr->objResultPtr;
if (Tcl_IsShared(objResultPtr)) {
TclDecrRefCount(objResultPtr);
@@ -991,11 +1001,11 @@ 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);
@@ -1173,8 +1183,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) {
/*
@@ -1225,7 +1235,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++) {
@@ -1285,10 +1295,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;
@@ -1391,13 +1399,11 @@ TclMergeReturnOptions(
Tcl_Obj **keys = GetKeys();
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;
diff --git a/generic/tclScan.c b/generic/tclScan.c
index c599797..4d86382 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -10,6 +10,7 @@
*/
#include "tclInt.h"
+#include "tclTomMath.h"
/*
* Flag values used by Tcl_ScanObjCmd.
@@ -28,15 +29,17 @@
* character set.
*/
+typedef struct {
+ Tcl_UniChar start;
+ Tcl_UniChar end;
+} Range;
+
typedef struct CharSet {
int exclude; /* 1 if this is an exclusion set. */
int nchars;
Tcl_UniChar *chars;
int nranges;
- struct Range {
- Tcl_UniChar start;
- Tcl_UniChar end;
- } *ranges;
+ Range *ranges;
} CharSet;
/*
@@ -101,9 +104,9 @@ BuildCharSet(
end += TclUtfToUniChar(end, &ch);
}
- cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
+ cset->chars = (Tcl_UniChar *)ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
if (nranges > 0) {
- cset->ranges = ckalloc(sizeof(struct Range) * nranges);
+ cset->ranges = (Range *)ckalloc(sizeof(Range) * nranges);
} else {
cset->ranges = NULL;
}
@@ -259,12 +262,12 @@ ValidateFormat(
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
- int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
- char buf[TCL_UTF_MAX+1] = "";
+ int *nassign = (int *)TclStackAlloc(interp, nspace * sizeof(int));
Tcl_Obj *errorMsg; /* Place to build an error messages. Note that
* these are messy operations because we do
* not want to use the formatting engine;
* we're inside there! */
+ char buf[5] = "";
/*
* Initialize an array that records the number of times a variable is
@@ -415,14 +418,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
@@ -483,7 +479,7 @@ ValidateFormat(
} else {
nspace += 16; /* formerly STATIC_LIST_SIZE */
}
- nassign = TclStackRealloc(interp, nassign,
+ nassign = (int *)TclStackRealloc(interp, nassign,
nspace * sizeof(int));
for (i = value; i < nspace; i++) {
nassign[i] = 0;
@@ -566,10 +562,9 @@ ValidateFormat(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
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. */
@@ -608,7 +603,7 @@ Tcl_ScanObjCmd(
*/
if (totalVars > 0) {
- objs = ckalloc(sizeof(Tcl_Obj *) * totalVars);
+ objs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
@@ -721,7 +716,7 @@ Tcl_ScanObjCmd(
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
- objPtr = Tcl_NewIntObj(string - baseString);
+ objPtr = Tcl_NewWideIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
@@ -884,7 +879,7 @@ Tcl_ScanObjCmd(
offset = TclUtfToUCS4(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
- objPtr = Tcl_NewIntObj(i);
+ objPtr = Tcl_NewWideIntObj(i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
@@ -895,13 +890,13 @@ Tcl_ScanObjCmd(
/*
* Scan an unsigned or signed integer.
*/
- objPtr = Tcl_NewLongObj(0);
+ objPtr = Tcl_NewWideIntObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
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') {
@@ -921,19 +916,49 @@ Tcl_ScanObjCmd(
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
- wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
+ wideValue = WIDE_MAX;
if (TclGetString(objPtr)[0] == '-') {
- wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
+ wideValue = WIDE_MIN;
}
}
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)) {
+ } else if (flags & SCAN_BIG) {
+ if (flags & SCAN_UNSIGNED) {
+ mp_int big;
+ int code = Tcl_GetBignumFromObj(interp, objPtr, &big);
+
+ if (code == TCL_OK) {
+ if (mp_isneg(&big)) {
+ code = TCL_ERROR;
+ }
+ mp_clear(&big);
+ }
+
+ if (code == 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 (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
@@ -944,13 +969,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 {
- Tcl_SetLongObj(objPtr, value);
+ TclSetIntObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
@@ -967,7 +998,7 @@ Tcl_ScanObjCmd(
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') {
@@ -986,8 +1017,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_ObjIntRep *irPtr
+ = TclFetchIntRep(objPtr, &tclDoubleType);
+ if (irPtr) {
+ dvalue = irPtr->doubleValue;
} else
#endif
{
@@ -1056,7 +1089,7 @@ Tcl_ScanObjCmd(
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
if (numVars) {
- objPtr = Tcl_NewIntObj(-1);
+ objPtr = Tcl_NewWideIntObj(-1);
} else {
if (objPtr) {
Tcl_SetListObj(objPtr, 0, NULL);
@@ -1065,7 +1098,7 @@ Tcl_ScanObjCmd(
}
}
} else if (numVars) {
- objPtr = Tcl_NewIntObj(result);
+ objPtr = Tcl_NewWideIntObj(result);
}
Tcl_SetObjResult(interp, objPtr);
}
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 749abcf..6444823 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -14,7 +14,7 @@
*/
#include "tclInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <float.h>
#include <math.h>
@@ -23,13 +23,6 @@
#endif
/*
- * Define KILL_OCTAL to suppress interpretation of numbers with leading zero
- * as octal. (Ceterum censeo: numeros octonarios delendos esse.)
- */
-
-#undef KILL_OCTAL
-
-/*
* This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754
* floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be
* uniquely determined by radix and by the widths of significand and exponent.
@@ -310,7 +303,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 +325,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 +487,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,8 +534,11 @@ 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 ALL_BITS (~(Tcl_WideUInt)0)
+#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
@@ -551,6 +547,20 @@ TclParseNumber(
*/
if (bytes == NULL) {
+ if (interp == NULL && endPtrPtr == NULL) {
+ if (TclHasIntRep(objPtr, &tclDictType)) {
+ /* A dict can never be a (single) number */
+ return TCL_ERROR;
+ }
+ if (TclHasIntRep(objPtr, &tclListType)) {
+ int length;
+ /* A list can only be a (single) number if its length == 1 */
+ TclListObjLength(NULL, objPtr, &length);
+ if (length != 1) {
+ return TCL_ERROR;
+ }
+ }
+ }
bytes = TclGetString(objPtr);
}
@@ -635,7 +645,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;
@@ -648,7 +658,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;
@@ -658,11 +668,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 */
@@ -682,9 +702,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(
@@ -703,9 +725,9 @@ TclParseNumber(
&& (((size_t)shift >=
CHAR_BIT*sizeof(Tcl_WideUInt))
|| (octalSignificandWide >
- (~(Tcl_WideUInt)0 >> shift)))) {
+ ((Tcl_WideUInt)-1 >> shift)))) {
octalSignificandOverflow = 1;
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
}
@@ -713,10 +735,17 @@ TclParseNumber(
octalSignificandWide =
(octalSignificandWide << shift) + (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) {
@@ -727,6 +756,10 @@ TclParseNumber(
numTrailZeros = 0;
state = OCTAL;
break;
+ } else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ /* Ignore numeric "white space" */
+ under = 1;
+ break;
}
/* FALLTHROUGH */
@@ -745,7 +778,7 @@ TclParseNumber(
goto endgame;
}
-#ifndef KILL_OCTAL
+#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
@@ -755,6 +788,7 @@ TclParseNumber(
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = BAD_OCTAL;
break;
} else if (isdigit(UCHAR(c))) {
@@ -770,12 +804,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;
}
@@ -798,14 +835,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;
}
@@ -820,19 +865,24 @@ TclParseNumber(
if (significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
- significandWide > (~(Tcl_WideUInt)0 >> shift))) {
+ significandWide > ((Tcl_WideUInt)-1 >> shift))) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig,
+ err = mp_init_u64(&significandBig,
significandWide);
}
}
if (!significandOverflow) {
significandWide = (significandWide << shift) + 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;
@@ -841,13 +891,18 @@ TclParseNumber(
acceptState = state;
acceptPoint = p;
acceptLen = len;
- /* FALLTHRU */
+ /* FALLTHRU */
case ZERO_B:
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;
}
@@ -862,30 +917,52 @@ TclParseNumber(
if (significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
- significandWide > (~(Tcl_WideUInt)0 >> shift))) {
+ significandWide > ((Tcl_WideUInt)-1 >> shift))) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig,
+ err = mp_init_u64(&significandBig,
significandWide);
}
}
if (!significandOverflow) {
significandWide = (significandWide << shift) + 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;
@@ -893,6 +970,7 @@ TclParseNumber(
acceptLen = len;
if (c == '0') {
numTrailZeros++;
+ under = 0;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
@@ -904,14 +982,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;
}
@@ -937,6 +1022,7 @@ TclParseNumber(
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
+ under = 0;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
@@ -953,8 +1039,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;
@@ -966,10 +1057,12 @@ TclParseNumber(
*/
if (c == '+') {
+ under = 0;
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
+ under = 0;
state = EXPONENT_SIGNUM;
break;
}
@@ -983,8 +1076,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;
@@ -1003,8 +1101,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;
@@ -1015,12 +1118,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;
}
@@ -1029,6 +1134,7 @@ TclParseNumber(
acceptState = state;
acceptPoint = p;
acceptLen = len;
+ under = 0;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
@@ -1036,24 +1142,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;
}
@@ -1065,12 +1175,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;
}
@@ -1080,6 +1192,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == '(') {
+ under = 0;
state = sNANPAREN;
break;
}
@@ -1090,12 +1203,14 @@ TclParseNumber(
*/
case sNANHEX:
if (c == ')') {
+ under = 0;
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
if (TclIsSpaceProcM(c)) {
+ under = 0;
break;
}
if (numSigDigs < 13) {
@@ -1110,6 +1225,7 @@ TclParseNumber(
}
numSigDigs++;
significandWide = (significandWide << 4) + d;
+ under = 0;
state = sNANHEX;
break;
}
@@ -1122,6 +1238,7 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
goto endgame;
+
}
p++;
len--;
@@ -1140,10 +1257,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.
@@ -1175,6 +1295,7 @@ TclParseNumber(
case ZERO_X:
case ZERO_O:
case ZERO_B:
+ case ZERO_D:
case LEADING_RADIX_POINT:
case EXPONENT_START:
case EXPONENT_SIGNUM:
@@ -1198,15 +1319,18 @@ 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) {
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:
@@ -1219,15 +1343,18 @@ 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) {
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:
@@ -1240,100 +1367,78 @@ 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) {
if (!octalSignificandOverflow) {
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);
}
TclSetBignumIntRep(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);
}
TclSetBignumIntRep(objPtr, &significandBig);
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
break;
case FRACTION:
@@ -1492,13 +1597,15 @@ AccumulateDecimalDigit(
*wideRepPtr = digit;
return 0;
} else if (numZeros >= maxpow10_wide
- || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) {
+ || w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) {
/*
* Wide multiplication will overflow. Expand the number to a
* bignum and fall through into the bignum case.
*/
- TclBNInitBignumFromWideUInt(bignumRepPtr, w);
+ if (mp_init_u64(bignumRepPtr, w) != MP_OKAY) {
+ return 0;
+ }
} else {
/*
* Wide multiplication.
@@ -1518,10 +1625,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
@@ -1532,18 +1641,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;
@@ -1644,7 +1756,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);
@@ -1693,7 +1807,7 @@ MakeHighPrecisionDouble(
long exponent) /* Power of 10 by which to multiply */
{
double retval;
- 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.
@@ -1858,6 +1972,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,
@@ -1906,7 +2021,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);
@@ -1916,8 +2033,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;
}
}
@@ -1927,20 +2045,27 @@ RefineApproximation(
* by 2**(M5+exponent+1), which is, of couse, 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
@@ -1950,17 +2075,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;
}
/*
@@ -2009,8 +2143,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;
}
/*
@@ -2049,7 +2190,7 @@ RefineApproximation(
*----------------------------------------------------------------------
*/
-static inline void
+static inline mp_err
MulPow5(
mp_int *base, /* Number to multiply. */
unsigned n, /* Power of 5 to multiply by. */
@@ -2058,23 +2199,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;
}
/*
@@ -2274,13 +2417,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;
@@ -2311,7 +2454,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) {
@@ -2492,9 +2635,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). */
@@ -2504,13 +2646,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;
@@ -2526,10 +2662,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;
}
}
@@ -2813,7 +2949,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
@@ -2864,7 +3000,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 -= 5.;
if (d > eps.d) {
@@ -2884,7 +3020,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);
@@ -2959,8 +3095,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. */
@@ -2977,7 +3111,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
@@ -3027,7 +3161,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.
@@ -3056,7 +3190,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);
@@ -3127,9 +3261,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. */
@@ -3143,7 +3274,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
@@ -3274,9 +3405,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. */
{
@@ -3288,8 +3416,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) {
@@ -3302,10 +3429,6 @@ ShouldBankerRoundUpToNextPowD(
return 1;
}
}
- if (convType == TCL_DD_STEELE0) {
- /* Biased rounding. */
- return 0;
- }
return isodd;
}
@@ -3335,8 +3458,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. */
@@ -3353,7 +3474,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. */
@@ -3363,23 +3484,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;
@@ -3390,13 +3519,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)
@@ -3422,7 +3559,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.
@@ -3450,7 +3587,7 @@ ShorteningBignumConversionPowD(
* number?
*/
- if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType,
+ if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd,
dPtr->w.word1 & 1, &temp)) {
if (digit == 9) {
*s++ = '9';
@@ -3478,10 +3615,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;
}
@@ -3500,7 +3641,7 @@ ShorteningBignumConversionPowD(
if (endPtr) {
*endPtr = s;
}
- return retval;
+ return (err == MP_OKAY) ? retval : NULL;
}
/*
@@ -3527,9 +3668,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. */
@@ -3543,33 +3681,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)
@@ -3577,7 +3718,7 @@ StrictBignumConversionPowD(
*/
i = 1;
- for (;;) {
+ while (err == MP_OKAY) {
if (b.used <= sd) {
digit = 0;
} else {
@@ -3609,7 +3750,7 @@ StrictBignumConversionPowD(
* Advance to the next digit.
*/
- mp_mul_d(&b, 10, &b);
+ err = mp_mul_d(&b, 10, &b);
++i;
}
@@ -3618,7 +3759,7 @@ StrictBignumConversionPowD(
* string.
*/
- mp_clear_multi(&b, &temp, NULL);
+ mp_clear(&b);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -3682,29 +3823,25 @@ 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);
+ 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_LT:
return 0;
case MP_EQ:
- if (convType == TCL_DD_STEELE0) {
- return 0;
- } else {
- return isodd;
- }
+ return isodd;
case MP_GT:
return 1;
}
@@ -3733,7 +3870,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. */
@@ -3745,7 +3881,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. */
@@ -3754,27 +3890,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;
@@ -3784,22 +3929,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!");
}
@@ -3811,9 +3963,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) {
@@ -3831,8 +3982,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';
@@ -3848,8 +3999,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);
}
@@ -3860,17 +4011,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;
/*
@@ -3900,11 +4055,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);
}
}
@@ -3919,7 +4076,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) {
@@ -3948,8 +4105,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. */
@@ -3960,34 +4115,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;
}
@@ -3997,7 +4163,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!");
}
@@ -4009,12 +4175,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.
*/
@@ -4024,16 +4189,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
@@ -4047,8 +4216,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];
@@ -4065,8 +4234,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;
@@ -4083,7 +4251,7 @@ StrictBignumConversion(
* string.
*/
- mp_clear_multi(&b, &S, &temp, &dig, NULL);
+ mp_clear_multi(&b, &S, &dig, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4119,22 +4287,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.
@@ -4145,7 +4304,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.
@@ -4178,10 +4337,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 */
@@ -4249,18 +4404,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
@@ -4286,7 +4441,7 @@ TclDoubleDigits(
* denominator.
*/
- if (flags & TCL_DD_SHORTEN_FLAG) {
+ if (flags & TCL_DD_SHORTEST) {
int m2minus = b2;
int m2plus;
int m5 = b5;
@@ -4333,7 +4488,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) {
/*
@@ -4352,7 +4507,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 {
@@ -4361,7 +4516,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 {
@@ -4389,7 +4544,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) {
/*
@@ -4406,7 +4561,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 {
/*
@@ -4416,7 +4571,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);
}
}
@@ -4454,6 +4609,7 @@ TclInitDoubleConversion(void)
Tcl_WideUInt iv;
} bitwhack;
#endif
+ mp_err err = MP_OKAY;
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
@@ -4510,16 +4666,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");
}
/*
@@ -4607,10 +4766,12 @@ 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.
@@ -4626,21 +4787,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);
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;
}
@@ -4661,11 +4827,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;
/*
@@ -4694,11 +4862,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) {
@@ -4707,12 +4877,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 {
@@ -4721,13 +4891,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);
}
}
@@ -4735,8 +4907,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);
@@ -4774,14 +4949,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);
@@ -4791,19 +4968,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];
@@ -4831,14 +5015,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);
@@ -4849,11 +5035,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];
@@ -4895,6 +5084,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.
@@ -4903,13 +5093,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);
}
/*
@@ -4917,8 +5109,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);
@@ -4966,7 +5160,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)) {
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 656d6ce..78e49f9 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -35,18 +35,10 @@
*/
#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:
*/
@@ -145,7 +137,7 @@ GrowStringBuffer(
char *ptr = NULL;
int attempt;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
@@ -350,10 +342,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);
}
@@ -430,13 +420,14 @@ Tcl_GetCharLength(
* 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) {
+ if (TclIsPureByteArray(objPtr)) {
int length;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
@@ -458,18 +449,6 @@ Tcl_GetCharLength(
if (numChars == -1) {
TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = 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.
- */
-
- FillUnicodeRep(objPtr);
- }
-#endif
}
return numChars;
}
@@ -491,16 +470,16 @@ Tcl_GetCharLength(
*----------------------------------------------------------------------
*/
int
-TclCheckEmptyString (
+TclCheckEmptyString(
Tcl_Obj *objPtr)
{
int length = -1;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
return TCL_EMPTYSTRING_YES;
}
- if (TclIsPureList(objPtr)) {
+ if (TclListObjIsCanonical(objPtr)) {
Tcl_ListObjLength(NULL, objPtr, &length);
return length == 0;
}
@@ -519,10 +498,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,64 +513,8 @@ TclCheckEmptyString (
*----------------------------------------------------------------------
*/
-Tcl_UniChar
-Tcl_GetUniChar(
- Tcl_Obj *objPtr, /* The object to get the Unicode charater
- * from. */
- int index) /* Get the index'th Unicode character. */
-{
- String *stringPtr;
- int length;
-
- if (index < 0) {
- return 0xFFFD;
- }
-
- /*
- * 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.
- */
-
- if (TclIsPureByteArray(objPtr)) {
- unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
- if (index >= length) {
- return 0xFFFD;
- }
-
- return (Tcl_UniChar) bytes[index];
- }
-
- /*
- * OK, need to work with the object as a string.
- */
-
- SetStringFromAny(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 (Tcl_UniChar) objPtr->bytes[index];
- }
- FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
-
- if (index >= stringPtr->numChars) {
- return 0xFFFD;
- }
- return stringPtr->unicode[index];
-}
-
-#if TCL_UTF_MAX == 4
int
-TclGetUCS4(
+Tcl_GetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
int index) /* Get the index'th Unicode character. */
@@ -642,7 +566,7 @@ TclGetUCS4(
return -1;
}
ch = stringPtr->unicode[index];
-#if TCL_UTF_MAX <= 4
+#if TCL_UTF_MAX <= 3
/* See: bug [11ae2be95dac9417] */
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x400) {
@@ -660,7 +584,6 @@ TclGetUCS4(
#endif
return ch;
}
-#endif
/*
*----------------------------------------------------------------------
@@ -681,6 +604,8 @@ TclGetUCS4(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_GetUnicode
Tcl_UniChar *
Tcl_GetUnicode(
Tcl_Obj *objPtr) /* The object to find the unicode string
@@ -688,6 +613,7 @@ Tcl_GetUnicode(
{
return Tcl_GetUnicodeFromObj(objPtr, NULL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -824,15 +750,15 @@ Tcl_GetRange(
if (last < first) {
return Tcl_NewObj();
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
/* See: bug [11ae2be95dac9417] */
if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
- && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
+ && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
++first;
}
if ((last + 1 < stringPtr->numChars)
- && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
- && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
+ && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
+ && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
++last;
}
#endif
@@ -952,7 +878,7 @@ Tcl_SetObjLength(
/*
* Need to enlarge the buffer.
*/
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = (char *)ckalloc(length + 1);
} else {
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1);
@@ -1058,7 +984,7 @@ Tcl_AttemptSetObjLength(
char *newBytes;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
newBytes = (char *)attemptckalloc(length + 1);
} else {
newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1);
@@ -1354,11 +1280,7 @@ Tcl_AppendUnicodeToObj(
* 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);
@@ -1399,18 +1321,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
@@ -1470,16 +1392,12 @@ Tcl_AppendObjToObj(
* 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 (TclHasIntRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
@@ -1500,7 +1418,7 @@ Tcl_AppendObjToObj(
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
- if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
+ if ((numChars >= 0) && TclHasIntRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
@@ -1508,11 +1426,7 @@ Tcl_AppendObjToObj(
AppendUtfToUtfRep(objPtr, bytes, length);
- if (numChars >= 0 && appendNumChars >= 0
-#if COMPAT
- && appendNumChars == length
-#endif
- ) {
+ if (numChars >= 0 && appendNumChars >= 0) {
stringPtr->numChars = numChars + appendNumChars;
}
}
@@ -1636,14 +1550,6 @@ AppendUnicodeToUtfRep(
if (stringPtr->numChars != -1) {
stringPtr->numChars += numChars;
}
-
-#if COMPAT
- /*
- * Invalidate the unicode rep.
- */
-
- stringPtr->hasUnicode = 0;
-#endif
}
/*
@@ -2091,6 +1997,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;
@@ -2129,12 +2054,10 @@ Tcl_AppendFormatToObj(
goto error;
}
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;
@@ -2142,14 +2065,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': {
@@ -2160,53 +2079,58 @@ Tcl_AppendFormatToObj(
mp_int big;
int toAppend, isNegative = 0;
+#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;
}
segment = Tcl_NewObj();
@@ -2220,18 +2144,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;
@@ -2239,6 +2160,14 @@ 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
}
}
@@ -2249,7 +2178,7 @@ Tcl_AppendFormatToObj(
const char *bytes;
if (useShort) {
- pure = Tcl_NewIntObj((int) s);
+ pure = Tcl_NewWideIntObj(s);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
pure = Tcl_NewWideIntObj(w);
@@ -2257,7 +2186,7 @@ Tcl_AppendFormatToObj(
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
- pure = Tcl_NewLongObj(l);
+ pure = Tcl_NewWideIntObj(l);
}
Tcl_IncrRefCount(pure);
bytes = TclGetStringFromObj(pure, &length);
@@ -2310,6 +2239,7 @@ Tcl_AppendFormatToObj(
case 'u':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
@@ -2346,7 +2276,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);
@@ -2375,7 +2305,7 @@ Tcl_AppendFormatToObj(
* Need to be sure zero becomes "0", not "".
*/
- if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
@@ -2385,7 +2315,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;
@@ -2442,6 +2372,8 @@ Tcl_AppendFormatToObj(
break;
}
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
@@ -2510,6 +2442,12 @@ Tcl_AppendFormatToObj(
errCode = "OVERFLOW";
goto errorMsg;
}
+ if (ch == 'A') {
+ char *p = TclGetString(segment) + 1;
+ *p = 'x';
+ p = strchr(p, 'P');
+ if (p) *p = 'p';
+ }
break;
}
default:
@@ -2681,7 +2619,7 @@ AppendPrintfToObjVA(
end = q;
}
- q = bytes + TCL_UTF_MAX;
+ q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
@@ -2697,33 +2635,49 @@ AppendPrintfToObjVA(
case 'u':
case 'd':
case 'o':
+ case 'p':
case 'x':
case 'X':
seekingConversion = 0;
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':
@@ -2738,9 +2692,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':
@@ -2840,7 +2820,7 @@ TclGetStringStorage(
{
String *stringPtr;
- if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) {
+ if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, (int *)sizePtr);
}
@@ -2848,6 +2828,906 @@ TclGetStringStorage(
*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,
+ int count,
+ int flags)
+{
+ Tcl_Obj *objResultPtr;
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+ int length = 0, unichar = 0, 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 (TclHasIntRep(objPtr, &tclStringType)) {
+ String *stringPtr = GET_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. */
+ Tcl_GetUnicodeFromObj(objPtr, &length);
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ Tcl_GetStringFromObj(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,
+ Tcl_GetByteArrayFromObj(objResultPtr, NULL),
+ (count - done) * length);
+ } else if (unichar) {
+ /*
+ * Efficiently produce a pure Tcl_UniChar array result.
+ */
+
+ if (!inPlace || Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), 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",
+ 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;
+ }
+ Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr),
+ (count - done) * length);
+ } else {
+ /*
+ * Efficiently concatenate string reps.
+ */
+
+ if (!inPlace || Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
+ } else {
+ TclFreeIntRep(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,
+ int objc,
+ Tcl_Obj * const objv[],
+ int flags)
+{
+ Tcl_Obj *objResultPtr, * const *ov;
+ int oc, length = 0, binary = 1;
+ int allowUniChar = 1, requestUniChar = 0;
+ int first = objc - 1; /* Index of first value possibly not empty */
+ int last = 0; /* Index of last value possibly not empty */
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+
+ /* assert ( objc >= 0 ) */
+
+ if (objc <= 1) {
+ /* Only one or no objects; return first or empty */
+ return objc ? 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 ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) {
+ /* Prevent shimmer of non-string types. */
+ allowUniChar = 0;
+ }
+ }
+ } else {
+ /* assert (objPtr->typePtr != NULL) -- stork! */
+ binary = 0;
+ if (TclHasIntRep(objPtr, &tclStringType)) {
+ /* 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
+ */
+
+ int 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;
+ } else if (numBytes > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ }
+ } while (--oc);
+ } else if (allowUniChar && requestUniChar) {
+ /*
+ * 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)) {
+ int numChars;
+
+ Tcl_GetUnicodeFromObj(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 {
+ Tcl_GetStringFromObj(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)) {
+ int 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++;
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
+
+ if (numBytes) {
+ last = objc -oc -1;
+ }
+ if (oc || numBytes) {
+ Tcl_GetStringFromObj(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) {
+ int numBytes;
+ Tcl_Obj *objPtr = *ov++;
+
+ /* assert ( length > 0 && pendingPtr == NULL ) */
+
+ Tcl_GetStringFromObj(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)) {
+ int 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)) {
+ int more;
+ unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
+ memcpy(dst, src, more);
+ dst += more;
+ }
+ }
+ } else if (allowUniChar && requestUniChar) {
+ /* Efficiently produce a pure Tcl_UniChar array result */
+ Tcl_UniChar *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+
+ /* Ugly interface! Force resize of the unicode array. */
+ Tcl_GetUnicodeFromObj(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",
+ STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ dst = Tcl_GetUnicode(objResultPtr) + start;
+ } else {
+ Tcl_UniChar ch = 0;
+
+ /* Ugly interface! No scheme to init array size. */
+ objResultPtr = Tcl_NewUnicodeObj(&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",
+ STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ dst = Tcl_GetUnicode(objResultPtr);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int more;
+ Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more);
+ memcpy(dst, src, more * sizeof(Tcl_UniChar));
+ dst += more;
+ }
+ }
+ } else {
+ /* Efficiently concatenate string reps */
+ char *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+
+ Tcl_GetStringFromObj(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 ) */
+ TclFreeIntRep(objResultPtr);
+ } else {
+ objResultPtr = Tcl_NewObj(); /* 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)) {
+ int more;
+ char *src = Tcl_GetStringFromObj(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 */
+ int reqlength) /* requested length */
+{
+ char *s1, *s2;
+ int empty, length, match, s1len, s2len;
+ memCmpFn_t memCmpFn;
+
+ if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
+ /*
+ * Always match at 0 chars of if it is the same obj.
+ */
+ 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 (TclHasIntRep(value1Ptr, &tclStringType)
+ && TclHasIntRep(value2Ptr, &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)) {
+ s1 = value1Ptr->bytes;
+ s2 = value2Ptr->bytes;
+ memCmpFn = memcmp;
+ } else {
+ s1 = (char *) Tcl_GetUnicode(value1Ptr);
+ s2 = (char *) Tcl_GetUnicode(value2Ptr);
+ if (
+#ifdef WORDS_BIGENDIAN
+ 1
+#else
+ checkEq
+#endif
+ ) {
+ memCmpFn = memcmp;
+ s1len *= sizeof(Tcl_UniChar);
+ s2len *= sizeof(Tcl_UniChar);
+ } else {
+ memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
+ }
+ }
+ }
+ } 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) {
+ /*
+ * 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);
+ }
+ }
+ }
+
+ length = (s1len < s2len) ? s1len : s2len;
+ if (reqlength > 0 && reqlength < length) {
+ length = reqlength;
+ } else if (reqlength < 0) {
+ /*
+ * The requested length is negative, so we ignore it by setting it
+ * to length + 1 so we correct the match var.
+ */
+
+ reqlength = length + 1;
+ }
+
+ if (checkEq && (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, (size_t) 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,
+ int start)
+{
+ int lh, ln = Tcl_GetCharLength(needle);
+ Tcl_Obj *result;
+ int value = -1;
+ Tcl_UniChar *check, *end, *uh, *un;
+
+ 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 = Tcl_GetUnicodeFromObj(needle, &ln);
+ uh = Tcl_GetUnicodeFromObj(haystack, &lh);
+ if ((lh < ln) || (start > lh - ln)) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto firstEnd;
+ }
+ end = uh + lh;
+
+ for (check = uh + start; check + ln <= end; check++) {
+ if ((*check == *un) && (0 ==
+ memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
+ value = (check - uh);
+ goto firstEnd;
+ }
+ }
+ firstEnd:
+ TclNewIntObj(result, value);
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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)
+{
+ int lh, ln = Tcl_GetCharLength(needle);
+ Tcl_Obj *result;
+ int value = -1;
+ Tcl_UniChar *check, *uh, *un;
+
+ 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 = Tcl_GetUnicodeFromObj(haystack, &lh);
+ un = Tcl_GetUnicodeFromObj(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 = uh + last + 1 - ln;
+ while (check >= uh) {
+ if ((*check == un[0])
+ && (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ value = (check - uh);
+ goto lastEnd;
+ }
+ check--;
+ }
+ lastEnd:
+ TclNewIntObj(result, value);
+ return result;
+}
+
/*
*---------------------------------------------------------------------------
*
@@ -2856,9 +3736,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.
@@ -2892,16 +3772,18 @@ ReverseBytes(
Tcl_Obj *
TclStringReverse(
- Tcl_Obj *objPtr)
+ Tcl_Obj *objPtr,
+ int flags)
{
String *stringPtr;
Tcl_UniChar ch = 0;
+ int inPlace = flags & TCL_STRING_IN_PLACE;
if (TclIsPureByteArray(objPtr)) {
int 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);
@@ -2915,7 +3797,7 @@ TclStringReverse(
Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
Tcl_UniChar *src = from + stringPtr->numChars;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
Tcl_UniChar *to;
/*
@@ -2947,7 +3829,7 @@ TclStringReverse(
int numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewObj();
Tcl_SetObjLength(objPtr, numBytes);
}
@@ -2996,6 +3878,151 @@ 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;
+
+ /* Caller is expected to pass sensible arguments */
+ assert ( count >= 0 ) ;
+ assert ( first >= 0 ) ;
+
+ /* Replace nothing with nothing */
+ if ((insertPtr == NULL) && (count == 0)) {
+ if (inPlace) {
+ return objPtr;
+ } else {
+ return Tcl_DuplicateObj(objPtr);
+ }
+ }
+
+ /*
+ * 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)) {
+ int 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)) {
+ int 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... */
+ {
+ int numChars;
+ Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);
+
+ /* TODO: Is there an in-place option worth pursuing here? */
+
+ result = Tcl_NewUnicodeObj(ustring, first);
+ if (insertPtr) {
+ Tcl_AppendObjToObj(result, insertPtr);
+ }
+ if (first + count < numChars) {
+ Tcl_AppendUnicodeToObj(result, ustring + first + count,
+ numChars - first - count);
+ }
+
+ return result;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
@@ -3087,7 +4114,6 @@ DupStringInternalRep(
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
-#if COMPAT==0
if (srcStringPtr->numChars == -1) {
/*
* The String struct in the source value holds zero useful data. Don't
@@ -3130,41 +4156,6 @@ 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;
@@ -3189,10 +4180,10 @@ DupStringInternalRep(
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) {
+ if (!TclHasIntRep(objPtr, &tclStringType)) {
String *stringPtr = stringAlloc(0);
/*
@@ -3252,7 +4243,7 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, NULL, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
@@ -3270,7 +4261,7 @@ ExtendStringRepWithUnicode(
*/
int i, origLength, size = 0;
- char *dst, buf[4] = "";
+ char *dst;
String *stringPtr = GET_STRING(objPtr);
if (numChars < 0) {
@@ -3296,7 +4287,7 @@ ExtendStringRepWithUnicode(
}
for (i = 0; i < numChars && size >= 0; i++) {
- size += Tcl_UniCharToUtf((int) unicode[i], buf);
+ size += TclUtfCount(unicode[i]);
}
if (size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index 227e6bc..fc5a713 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -46,7 +46,7 @@
* tcl.h, but do not do that unless you are sure what you're doing!
*/
-typedef struct String {
+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
@@ -72,20 +72,21 @@ typedef struct String {
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
- STRING_MAXCHARS); \
+ (int)STRING_MAXCHARS); \
} \
} 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))
/*
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 7807083..2d2bc63 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -11,6 +11,7 @@
#include "tclInt.h"
#include "tommath_private.h"
+#include "tclTomMath.h"
#ifdef __CYGWIN__
# include <wchar.h>
@@ -35,33 +36,124 @@
#undef Tcl_NewIntObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
+#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
+#undef Tcl_GetUnicode
+#undef Tcl_GetUnicodeFromObj
+#undef Tcl_AppendUnicodeToObj
+#undef Tcl_NewUnicodeObj
+#undef Tcl_SetUnicodeObj
+#undef Tcl_UniCharNcasecmp
+#undef Tcl_UniCharCaseMatch
+#undef Tcl_UniCharLen
+#undef Tcl_UniCharNcmp
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
+#undef Tcl_SetExitProc
+#undef Tcl_SetPanicProc
#undef TclpGetPid
#undef TclSockMinimumBuffers
-#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
+#undef Tcl_SetLongObj
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt
-#undef TclBN_mp_tc_and
-#undef TclBN_mp_tc_or
-#undef TclBN_mp_tc_xor
+#undef TclWinNToHS
+#undef TclStaticPackage
+#undef Tcl_BackgroundError
+#define TclStaticPackage Tcl_StaticPackage
+#undef Tcl_UniCharToUtfDString
+#undef Tcl_UtfToUniCharDString
+#undef Tcl_UtfToUniChar
+#undef Tcl_MacOSXOpenBundleResources
+
+#if TCL_UTF_MAX > 3
+static void uniCodePanic(void) {
+ Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
+}
+# define Tcl_GetUnicode (int *(*)(Tcl_Obj *))(void *)uniCodePanic
+# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *))(void *)uniCodePanic
+# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar))(void *)uniCodePanic
+# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic
+# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic
+# define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic
+# define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int))(void *)uniCodePanic
+# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *))(void *)uniCodePanic
+# define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic
+#endif
+
+#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_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 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_xor mp_xor
+#define TclBN_mp_zero mp_zero
+#define TclBN_s_mp_add s_mp_add
+#define TclBN_s_mp_balance_mul 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 NULL
/* 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
@@ -71,33 +163,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;
@@ -110,6 +210,117 @@ 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
+#else
+
+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, (size_t)maxlen, NULL, radix);
+}
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
@@ -136,14 +347,30 @@ static const char *TclGetStartupScriptFileName(void)
}
return Tcl_GetString(path);
}
-
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
+#undef TclWinGetPlatformId
+#undef TclWinResetInterfaces
+#undef TclWinSetInterfaces
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
+#define 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
@@ -163,20 +390,17 @@ static unsigned short TclWinNToHS(unsigned short ns) {
# 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,
@@ -199,6 +423,7 @@ TclWinGetServByName(const char *name, const char *proto)
{
return getservbyname(name, proto);
}
+#endif /* TCL_NO_DEPRECATED */
#define TclWinNoBackslash winNoBackslash
static char *
@@ -218,7 +443,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;
}
@@ -228,134 +453,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
@@ -363,33 +482,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
- register 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 {
@@ -405,7 +502,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 {
@@ -417,10 +514,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);
}
@@ -429,51 +532,174 @@ 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_GetStringResult
+# define Tcl_GetStringResult 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
+# define Tcl_GetUnicode 0
+#if TCL_UTF_MAX < 4
+# define Tcl_AppendUnicodeToObj 0
+# define Tcl_UniCharCaseMatch 0
+# define Tcl_UniCharLen 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
+#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
-mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
-{
- return mp_to_ubin(a, b, INT_MAX, NULL);
-}
-
-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, (size_t)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
@@ -484,6 +710,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 = {
@@ -601,22 +836,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 */
@@ -667,8 +902,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 */
@@ -747,8 +982,8 @@ static const TclIntStubs tclIntStubs = {
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
- 0, /* 258 */
- 0, /* 259 */
+ TclpCreateTemporaryDirectory, /* 258 */
+ TclGetBytesFromObj, /* 259 */
TclUnusedStubEntry, /* 260 */
};
@@ -891,7 +1126,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 */
@@ -919,12 +1154,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 */
@@ -933,16 +1168,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 */
0, /* 71 */
0, /* 72 */
TclBN_mp_tc_and, /* 73 */
@@ -1324,7 +1559,7 @@ const TclStubs tclStubs = {
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
- Tcl_UtfToUniChar, /* 336 */
+ Tcl_UtfToChar16, /* 336 */
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
@@ -1342,8 +1577,8 @@ const TclStubs tclStubs = {
Tcl_UniCharIsWordChar, /* 351 */
Tcl_UniCharLen, /* 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 */
@@ -1619,25 +1854,24 @@ 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 */
- TclUnusedStubEntry, /* 649 */
+ Tcl_OpenTcpServerEx, /* 631 */
+ TclZipfs_Mount, /* 632 */
+ TclZipfs_Unmount, /* 633 */
+ TclZipfs_TclLibrary, /* 634 */
+ TclZipfs_MountBuffer, /* 635 */
+ Tcl_FreeIntRep, /* 636 */
+ Tcl_InitStringRep, /* 637 */
+ Tcl_FetchIntRep, /* 638 */
+ Tcl_StoreIntRep, /* 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 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index bebea81..22e8b9b 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -24,13 +24,10 @@ const TclIntStubs *tclIntStubsPtr = NULL;
const TclIntPlatStubs *tclIntPlatStubsPtr = 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,7 +51,8 @@ MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
- int exact)
+ int exact,
+ int magic)
{
Interp *iPtr = (Interp *) interp;
const char *actualVersion = NULL;
@@ -67,9 +65,9 @@ Tcl_InitStubs(
* 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;
return NULL;
}
@@ -77,12 +75,12 @@ Tcl_InitStubs(
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,7 +89,7 @@ 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);
return NULL;
@@ -103,12 +101,16 @@ Tcl_InitStubs(
}
}
}
- tclStubsPtr = (TclStubs *)pkgData;
+ if (((exact&0xFF00) < 0x900)) {
+ /* We are running Tcl 8.x */
+ stubsPtr = (TclStubs *)pkgData;
+ }
+ 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 37aafd2..8cca744 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -20,6 +20,11 @@
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
+#ifdef TCL_WITH_EXTERNAL_TOMMATH
+# include "tommath.h"
+#else
+# include "tclTomMath.h"
+#endif
#include "tclOO.h"
#include <math.h>
@@ -29,11 +34,6 @@
#include "tclRegexp.h"
/*
- * Required for TestlocaleCmd
- */
-#include <locale.h>
-
-/*
* Required for the TestChannelCmd and TestChannelEventCmd
*/
#include "tclIO.h"
@@ -41,17 +41,8 @@
/*
* Declare external functions used in Windows tests.
*/
-
-/*
- * 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.
- */
-
-#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
@@ -75,6 +66,18 @@ 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 testFlags; /* bit field for tests. Is set by testsocket
+ * test procedure */
+};
+
TCL_DECLARE_MUTEX(asyncTestMutex)
static TestAsyncHandler *firstHandler = NULL;
@@ -155,62 +158,63 @@ static TestChannel *firstDetached;
* 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);
+#if TCL_THREADS
+static Tcl_ThreadCreateType AsyncThreadProc(void *);
#endif
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_CmdProc TestcmdinfoCmd;
static Tcl_CmdProc TestcmdtokenCmd;
@@ -228,7 +232,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 +245,13 @@ 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 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,6 +260,8 @@ 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,
@@ -279,10 +281,13 @@ 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;
@@ -435,8 +440,6 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
- Tcl_ValueType t3ArgTypes[2];
-
Tcl_Obj **objv, *objPtr;
int objc, index;
static const char *const specialOptions[] = {
@@ -444,18 +447,20 @@ Tcltest_Init(
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ 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_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -538,6 +543,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",
@@ -545,6 +552,7 @@ 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, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
@@ -555,6 +563,10 @@ 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,
@@ -566,9 +578,9 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
- (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
- (ClientData) TCL_LEAVE_ERR_MSG, NULL);
+ INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
@@ -585,13 +597,13 @@ Tcltest_Init(
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
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,
@@ -602,17 +614,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);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -620,7 +631,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;
}
@@ -689,7 +700,7 @@ int
Tcltest_SafeInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
@@ -714,7 +725,7 @@ Tcltest_SafeInit(
static int
TestasyncCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -722,7 +733,6 @@ TestasyncCmd(
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- (void)dummy;
if (argc < 2) {
wrongNumArgs:
@@ -800,7 +810,7 @@ TestasyncCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
-#ifdef TCL_THREADS
+#if TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
@@ -840,7 +850,7 @@ TestasyncCmd(
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. */
@@ -899,10 +909,10 @@ AsyncHandlerProc(
*----------------------------------------------------------------------
*/
-#ifdef TCL_THREADS
+#if 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;
@@ -925,7 +935,7 @@ AsyncThreadProc(
static int
TestbumpinterpepochObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -960,13 +970,12 @@ TestbumpinterpepochObjCmd(
static int
TestcmdinfoCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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],
@@ -974,7 +983,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);
@@ -1011,11 +1020,11 @@ 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));
} else {
@@ -1031,10 +1040,10 @@ TestcmdinfoCmd(
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;
@@ -1042,10 +1051,10 @@ 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;
@@ -1053,7 +1062,7 @@ CmdProc2(
static void
CmdDelProc1(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
@@ -1062,7 +1071,7 @@ CmdDelProc1(
static void
CmdDelProc2(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
@@ -1088,7 +1097,7 @@ CmdDelProc2(
static int
TestcmdtokenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1104,9 +1113,9 @@ TestcmdtokenCmd(
}
if (strcmp(argv[1], "create") == 0) {
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
- (ClientData) "original", NULL);
+ (void *) "original", NULL);
sprintf(buf, "%p", (void *)token);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
@@ -1151,7 +1160,7 @@ TestcmdtokenCmd(
static int
TestcmdtraceCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1207,11 +1216,11 @@ TestcmdtraceCmd(
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
- (ClientData) &deleteCalled, ObjTraceDeleteProc);
- result = Tcl_Eval(interp, argv[2]);
+ &deleteCalled, ObjTraceDeleteProc);
+ result = Tcl_EvalEx(interp, argv[2], -1, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
- Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC);
+ Tcl_AppendResult(interp, "Delete wasn't called", NULL);
return TCL_ERROR;
} else {
return result;
@@ -1222,7 +1231,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], -1, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1240,16 +1249,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(ClientData),
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
{
@@ -1267,16 +1275,14 @@ CmdTraceProc(
static void
CmdTraceDeleteProc(
- ClientData clientData, /* Unused. */
+ TCL_UNUSED(ClientData),
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(ClientData),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
@@ -1289,13 +1295,13 @@ CmdTraceDeleteProc(
static int
ObjTraceProc(
- ClientData clientData, /* unused */
+ TCL_UNUSED(ClientData),
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]);
@@ -1317,7 +1323,7 @@ ObjTraceProc(
static void
ObjTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
@@ -1346,7 +1352,7 @@ ObjTraceDeleteProc(
static int
TestcreatecommandCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1376,10 +1382,10 @@ TestcreatecommandCmd(
static int
CreatedCommandProc(
- ClientData clientData, /* String to return. */
+ TCL_UNUSED(ClientData),
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;
@@ -1398,10 +1404,10 @@ CreatedCommandProc(
static int
CreatedCommandProc2(
- ClientData clientData, /* String to return. */
+ TCL_UNUSED(ClientData),
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;
@@ -1436,7 +1442,7 @@ CreatedCommandProc2(
static int
TestdcallCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1451,10 +1457,10 @@ TestdcallCmd(
}
if (id < 0) {
Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) INT2PTR(-id));
+ INT2PTR(-id));
} else {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
- (ClientData) INT2PTR(id));
+ INT2PTR(id));
}
}
Tcl_DeleteInterp(delInterp);
@@ -1468,7 +1474,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);
@@ -1500,7 +1506,7 @@ DelCallbackProc(
static int
TestdelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1509,7 +1515,7 @@ TestdelCmd(
Tcl_Interp *slave;
if (argc != 4) {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
@@ -1523,17 +1529,17 @@ TestdelCmd(
dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
- Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
+ Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
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;
@@ -1545,11 +1551,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, -1, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
@@ -1575,7 +1581,7 @@ DelDeleteProc(
static int
TestdelassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1604,32 +1610,27 @@ 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.
*
*-----------------------------------------------------------------------------
*/
static int
-TestdoubledigitsObjCmd(ClientData unused,
- /* NULL */
- Tcl_Interp* interp,
- /* Tcl interpreter */
- int objc,
- /* Parameter count */
- Tcl_Obj* const objv[])
- /* Parameter vector */
+TestdoubledigitsObjCmd(
+ TCL_UNUSED(ClientData),
+ 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
};
@@ -1653,8 +1654,8 @@ TestdoubledigitsObjCmd(ClientData unused,
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_FetchIntRep(objv[1], doubleType)
+ && TclIsNaN(objv[1]->internalRep.doubleValue)) {
status = TCL_OK;
memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
}
@@ -1672,7 +1673,7 @@ TestdoubledigitsObjCmd(ClientData unused,
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
return TCL_ERROR;
}
- type |= TCL_DD_SHORTEN_FLAG;
+ type |= TCL_DD_SHORTEST;
}
str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
strObj = Tcl_NewStringObj(str, endPtr-str);
@@ -1704,7 +1705,7 @@ TestdoubledigitsObjCmd(ClientData unused,
static int
TestdstringCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1713,7 +1714,7 @@ TestdstringCmd(
if (argc < 2) {
wrongNumArgs:
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "append") == 0) {
@@ -1749,11 +1750,11 @@ TestdstringCmd(
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
- Tcl_SetResult(interp, "short", TCL_STATIC);
+ Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
- Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
+ Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
- char *s = ckalloc(100);
+ char *s = (char *)ckalloc(100);
strcpy(s, "This is a malloc-ed string");
Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(argv[2], "special") == 0) {
@@ -1805,9 +1806,9 @@ TestdstringCmd(
* Tcl_DStringGetResult handles freeProc's other than free.
*/
-static void SpecialFree(blockPtr)
- char *blockPtr; /* Block to free. */
-{
+static void SpecialFree(
+ char *blockPtr /* Block to free. */
+) {
ckfree(blockPtr - 16);
}
@@ -1830,7 +1831,7 @@ static void SpecialFree(blockPtr)
static int
TestencodingObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1858,16 +1859,16 @@ TestencodingObjCmd(
if (objc != 5) {
return TCL_ERROR;
}
- encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding));
+ encodingPtr = (TclEncoding*)ckalloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
encodingPtr->toUtfCmd = (char *)ckalloc(length + 1);
- memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
+ memcpy(encodingPtr->toUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[4], &length);
encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1);
- memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
+ memcpy(encodingPtr->fromUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[2], &length);
@@ -1875,7 +1876,7 @@ TestencodingObjCmd(
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
type.freeProc = EncodingFreeProc;
- type.clientData = (ClientData) encodingPtr;
+ type.clientData = encodingPtr;
type.nullSize = 1;
Tcl_CreateEncoding(&type);
@@ -1885,9 +1886,12 @@ TestencodingObjCmd(
if (objc != 3) {
return TCL_ERROR;
}
- encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
- Tcl_FreeEncoding(encoding);
- Tcl_FreeEncoding(encoding);
+ if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) {
+ return TCL_ERROR;
+ }
+ Tcl_FreeEncoding(encoding); /* Free returned reference */
+ Tcl_FreeEncoding(encoding); /* Free to match CREATE */
+ TclFreeIntRep(objv[2]); /* Free the cached ref */
break;
}
return TCL_OK;
@@ -1895,11 +1899,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. */
@@ -1910,13 +1914,13 @@ EncodingToUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
- memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
+ memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len);
Tcl_ResetResult(encodingPtr->interp);
*srcReadPtr = srcLen;
@@ -1927,11 +1931,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. */
@@ -1942,13 +1946,13 @@ EncodingFromUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
len = dstLen;
}
- memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
+ memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len);
Tcl_ResetResult(encodingPtr->interp);
*srcReadPtr = srcLen;
@@ -1959,7 +1963,7 @@ EncodingFromUtfProc(
static void
EncodingFreeProc(
- ClientData clientData) /* ClientData associated with type. */
+ void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = (TclEncoding *)clientData;
@@ -1987,7 +1991,7 @@ EncodingFreeProc(
static int
TestevalexObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2032,7 +2036,7 @@ TestevalexObjCmd(
static int
TestevalobjvObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2081,7 +2085,7 @@ TestevalobjvObjCmd(
static int
TesteventObjCmd(
- ClientData unused, /* Not used */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
@@ -2166,7 +2170,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;
@@ -2178,14 +2182,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) {
@@ -2217,7 +2221,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 */
@@ -2260,7 +2264,7 @@ TesteventDeleteProc(
static int
TestexithandlerCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2277,10 +2281,10 @@ TestexithandlerCmd(
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) INT2PTR(value));
+ INT2PTR(value));
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
- (ClientData) INT2PTR(value));
+ INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create or delete", NULL);
@@ -2291,7 +2295,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;
@@ -2305,7 +2309,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;
@@ -2336,7 +2340,7 @@ ExitProcEven(
static int
TestexprlongCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2350,7 +2354,7 @@ TestexprlongCmd(
" expression\"", NULL);
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprLong(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2379,7 +2383,7 @@ TestexprlongCmd(
static int
TestexprlongobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2392,7 +2396,7 @@ TestexprlongobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2421,7 +2425,7 @@ TestexprlongobjCmd(
static int
TestexprdoubleCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2435,7 +2439,7 @@ TestexprdoubleCmd(
" expression\"", NULL);
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprDouble(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2465,7 +2469,7 @@ TestexprdoubleCmd(
static int
TestexprdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2478,7 +2482,7 @@ TestexprdoubleobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2507,7 +2511,7 @@ TestexprdoubleobjCmd(
static int
TestexprstringCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2539,7 +2543,7 @@ TestexprstringCmd(
static int
TestfilelinkCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -2606,7 +2610,7 @@ TestfilelinkCmd(
static int
TestgetassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2644,7 +2648,7 @@ TestgetassocdataCmd(
static int
TestgetplatformCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2684,7 +2688,7 @@ TestgetplatformCmd(
static int
TestinterpdeleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2724,7 +2728,7 @@ TestinterpdeleteCmd(
static int
TestlinkCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2732,7 +2736,7 @@ TestlinkCmd(
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
- static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
+ static Tcl_WideInt wideVar = 79;
static char *stringVar = NULL;
static char charVar = '@';
static unsigned char ucharVar = 130;
@@ -2742,7 +2746,7 @@ TestlinkCmd(
static long longVar = 123456789L;
static unsigned long ulongVar = 3456789012UL;
static float floatVar = 4.5;
- static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123);
+ static Tcl_WideUInt uwideVar = 123;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
@@ -2783,7 +2787,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2791,7 +2795,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2799,7 +2803,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2807,7 +2811,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2815,7 +2819,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2823,7 +2827,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2831,7 +2835,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2839,7 +2843,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2847,7 +2851,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2855,7 +2859,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2863,7 +2867,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2871,7 +2875,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2879,7 +2883,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2887,7 +2891,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = (writable != 0) ? 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;
}
@@ -2932,10 +2936,10 @@ 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);
+ tmp = Tcl_NewWideIntObj((long)ulongVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
Tcl_PrintDouble(NULL, (double)floatVar, buffer);
@@ -3176,6 +3180,124 @@ TestlinkCmd(
/*
*----------------------------------------------------------------------
*
+ * TestlinkarrayCmd --
+ *
+ * This function is invoked to process the "testlinkarray" Tcl command.
+ * It is used to test the 'Tcl_LinkArray' function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates, deletes, and invokes variable links.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestlinkarrayCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *LinkOption[] = {
+ "update", "remove", "create", NULL
+ };
+ enum LinkOption { 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, length;
+ char *name, *arg;
+ Tcl_WideInt addr;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option args");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
+ &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum LinkOption) 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;
+
+ /*
+ * test on switch -r...
+ */
+
+ arg = Tcl_GetStringFromObj(objv[i], &length);
+ if (length < 2) {
+ goto wrongArgs;
+ }
+ if (arg[0] == '-') {
+ if (arg[1] != 'r') {
+ goto wrongArgs;
+ }
+ readonly = TCL_LINK_READ_ONLY;
+ i++;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
+ &typeIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
+ return TCL_ERROR;
+ }
+ name = Tcl_GetString(objv[i++]);
+
+ /*
+ * If no address is given request one in the underlying function
+ */
+
+ if (i < objc) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong address value", -1));
+ return TCL_ERROR;
+ }
+ } else {
+ addr = 0;
+ }
+ return Tcl_LinkArray(interp, name, INT2PTR(addr),
+ LinkTypes[typeIndex] | readonly, size);
+ }
+ return TCL_OK;
+
+ wrongArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
@@ -3192,14 +3314,13 @@ TestlinkCmd(
static int
TestlocaleCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
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
@@ -3238,142 +3359,6 @@ TestlocaleCmd(
/*
*----------------------------------------------------------------------
*
- * TestMathFunc --
- *
- * This is a user-defined math procedure to test out math procedures
- * with no arguments.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-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);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestMathFunc2 --
- *
- * This is a user-defined math procedure to test out math procedures
- * that do have arguments, in this case 2.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-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. */
-{
- int result = TCL_OK;
-
- /*
- * Return the maximum of the two arguments with the correct type.
- */
-
- 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;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- 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 {
- Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
- result = TCL_ERROR;
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* CleanupTestSetassocdataTests --
*
* This function is called when an interpreter is deleted to clean
@@ -3387,10 +3372,11 @@ 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);
}
@@ -3414,7 +3400,7 @@ CleanupTestSetassocdataTests(
static int
TestparserObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3470,7 +3456,7 @@ TestparserObjCmd(
static int
TestexprparserObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3617,7 +3603,7 @@ PrintParse(
static int
TestparsevarObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3658,7 +3644,7 @@ TestparsevarObjCmd(
static int
TestparsevarnameObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3704,6 +3690,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(ClientData),
+ 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(ClientData),
+ 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
@@ -3722,7 +3778,7 @@ TestparsevarnameObjCmd(
static int
TestregexpObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3846,7 +3902,7 @@ TestregexpObjCmd(
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(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);
@@ -3860,7 +3916,7 @@ TestregexpObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(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);
@@ -3907,8 +3963,8 @@ 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 {
@@ -4045,10 +4101,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(ClientData),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
@@ -4073,7 +4129,7 @@ TestreturnObjCmd(
static int
TestsetassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4087,7 +4143,7 @@ TestsetassocdataCmd(
return TCL_ERROR;
}
- buf = ckalloc(strlen(argv[2]) + 1);
+ buf = (char *)ckalloc(strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
@@ -4100,8 +4156,7 @@ TestsetassocdataCmd(
ckfree(oldData);
}
- Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests,
- (ClientData) buf);
+ Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf);
return TCL_OK;
}
@@ -4125,7 +4180,7 @@ TestsetassocdataCmd(
static int
TestsetplatformCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4174,7 +4229,7 @@ TestsetplatformCmd(
static int
TeststaticpkgCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4192,7 +4247,7 @@ TeststaticpkgCmd(
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
- tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
+ Tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
StaticInitProc, (safe) ? StaticInitProc : NULL);
return TCL_OK;
}
@@ -4202,7 +4257,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;
}
@@ -4225,7 +4280,7 @@ StaticInitProc(
static int
TesttranslatefilenameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4266,7 +4321,7 @@ TesttranslatefilenameCmd(
static int
TestupvarCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4285,7 +4340,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;
@@ -4318,13 +4373,13 @@ TestupvarCmd(
static int
TestseterrorcodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc > 6) {
- Tcl_SetResult(interp, "too many args", TCL_STATIC);
+ Tcl_AppendResult(interp, "too many args", NULL);
return TCL_ERROR;
}
switch (argc) {
@@ -4370,7 +4425,7 @@ TestseterrorcodeCmd(
static int
TestsetobjerrorcodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4398,7 +4453,7 @@ TestsetobjerrorcodeCmd(
static int
TestfeventCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4470,19 +4525,17 @@ TestfeventCmd(
static int
TestpanicCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(ClientData),
+ 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);
@@ -4491,7 +4544,7 @@ TestpanicCmd(
static int
TestfileCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
@@ -4573,7 +4626,7 @@ TestfileCmd(
static int
TestgetvarfullnameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4647,10 +4700,10 @@ TestgetvarfullnameCmd(
static int
GetTimesObjCmd(
- ClientData unused, /* Unused. */
+ TCL_UNUSED(ClientData),
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;
@@ -4659,8 +4712,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");
@@ -4675,10 +4726,10 @@ GetTimesObjCmd(
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
- objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
+ objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
- objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
+ objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4778,10 +4829,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;
}
@@ -4795,7 +4846,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;
}
@@ -4828,10 +4879,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(ClientData),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
@@ -4855,10 +4906,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(ClientData),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
@@ -4880,14 +4931,13 @@ NoopObjCmd(
static int
TeststringbytesObjCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
const unsigned char *p;
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
@@ -4921,13 +4971,12 @@ TeststringbytesObjCmd(
static int
TestpurebytesobjObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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?");
@@ -4969,14 +5018,13 @@ TestpurebytesobjObjCmd(
static int
TestsetbytearraylengthObjCmd(
- 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 n;
Tcl_Obj *obj = NULL;
- (void)dummy;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
@@ -5014,21 +5062,23 @@ TestsetbytearraylengthObjCmd(
static int
TestbytestringObjCmd(
- 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 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 *)TclGetBytesFromObj(interp, objv[1], &n);
+ if (p == NULL) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
@@ -5052,7 +5102,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. */
@@ -5061,7 +5111,7 @@ TestsetCmd(
const char *value;
if (argc == 2) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
+ Tcl_AppendResult(interp, "before get", NULL);
value = Tcl_GetVar2(interp, argv[1], NULL, flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5069,7 +5119,7 @@ TestsetCmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 3) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
+ Tcl_AppendResult(interp, "before set", NULL);
value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5084,7 +5134,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. */
@@ -5093,7 +5143,7 @@ Testset2Cmd(
const char *value;
if (argc == 3) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
+ Tcl_AppendResult(interp, "before get", NULL);
value = Tcl_GetVar2(interp, argv[1], argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5101,7 +5151,7 @@ Testset2Cmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 4) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
+ Tcl_AppendResult(interp, "before set", NULL);
value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5134,7 +5184,7 @@ Testset2Cmd(
static int
TestsaveresultCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -5166,16 +5216,17 @@ TestsaveresultCmd(
return TCL_ERROR;
}
+ freeCount = 0;
objPtr = NULL; /* Lint. */
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);
@@ -5190,13 +5241,12 @@ TestsaveresultCmd(
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]), -1, 0);
}
if (discard) {
@@ -5208,11 +5258,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:
@@ -5243,7 +5291,7 @@ TestsaveresultCmd(
static void
TestsaveresultFree(
- char *blockPtr)
+ TCL_UNUSED(char *))
{
freeCount++;
}
@@ -5267,10 +5315,10 @@ TestsaveresultFree(
static int
TestmainthreadCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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());
@@ -5278,7 +5326,7 @@ TestmainthreadCmd(
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
}
@@ -5328,14 +5376,14 @@ 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(ClientData),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
- exitMainLoop = 0;
- Tcl_SetMainLoop(MainLoop);
- return TCL_OK;
+ exitMainLoop = 0;
+ Tcl_SetMainLoop(MainLoop);
+ return TCL_OK;
}
/*
@@ -5357,13 +5405,13 @@ 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(ClientData),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
- exitMainLoop = 1;
- return TCL_OK;
+ exitMainLoop = 1;
+ return TCL_OK;
}
/*
@@ -5385,7 +5433,7 @@ TestexitmainloopCmd(
static int
TestChannelCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
@@ -5852,7 +5900,7 @@ TestChannelCmd(
static int
TestChannelEventCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5877,7 +5925,7 @@ TestChannelEventCmd(
cmd = argv[2];
len = strlen(cmd);
- if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {
+ if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName add eventSpec script\"", NULL);
@@ -5895,8 +5943,7 @@ TestChannelEventCmd(
return TCL_ERROR;
}
- esPtr = (EventScriptRecord *) ckalloc((unsigned)
- sizeof(EventScriptRecord));
+ esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
@@ -5907,12 +5954,12 @@ TestChannelEventCmd(
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
- if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {
+ if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) {
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName delete index\"", NULL);
@@ -5951,14 +5998,14 @@ TestChannelEventCmd(
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
return TCL_OK;
}
- if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {
+ if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName list\"", NULL);
@@ -5981,7 +6028,7 @@ TestChannelEventCmd(
return TCL_OK;
}
- if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {
+ if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName removeall\"", NULL);
@@ -5992,7 +6039,7 @@ TestChannelEventCmd(
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
}
@@ -6000,7 +6047,7 @@ TestChannelEventCmd(
return TCL_OK;
}
- if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
+ if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName delete index event\"", NULL);
@@ -6038,7 +6085,7 @@ TestChannelEventCmd(
}
esPtr->mask = mask;
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
- TclChannelEventScriptInvoker, (ClientData) esPtr);
+ TclChannelEventScriptInvoker, esPtr);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
@@ -6049,6 +6096,74 @@ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestSocketCmd(
+ TCL_UNUSED(ClientData),
+ 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;
+ 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;
+ }
+ statePtr->testFlags = atoi(argv[3]);
+ return TCL_OK;
+ }
+
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
+ "testflags", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
@@ -6064,7 +6179,7 @@ TestChannelEventCmd(
static int
TestWrongNumArgsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6077,7 +6192,7 @@ TestWrongNumArgsObjCmd(
* Don't use Tcl_WrongNumArgs here, as that is the function
* we want to test!
*/
- Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
@@ -6094,7 +6209,7 @@ TestWrongNumArgsObjCmd(
/*
* Asked for more arguments than were given.
*/
- Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
@@ -6120,7 +6235,7 @@ TestWrongNumArgsObjCmd(
static int
TestGetIndexFromObjStructObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6174,7 +6289,7 @@ TestGetIndexFromObjStructObjCmd(
static int
TestFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6190,7 +6305,7 @@ TestFilesystemObjCmd(
return TCL_ERROR;
}
if (boolVal) {
- res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
+ res = Tcl_FSRegister(interp, &testReportingFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&testReportingFilesystem);
@@ -6203,7 +6318,7 @@ TestFilesystemObjCmd(
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
static Tcl_Obj *lastPathPtr = NULL;
Tcl_Obj *newPathPtr;
@@ -6225,7 +6340,7 @@ TestReportInFilesystem(
return -1;
}
lastPathPtr = NULL;
- *clientDataPtr = (ClientData) newPathPtr;
+ *clientDataPtr = newPathPtr;
return TCL_OK;
}
@@ -6243,7 +6358,7 @@ TestReportGetNativePath(
static void
TestReportFreeInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
@@ -6253,9 +6368,9 @@ TestReportFreeInternalRep(
}
}
-static ClientData
+static void *
TestReportDupInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
@@ -6291,7 +6406,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), -1, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
@@ -6505,7 +6620,7 @@ TestReportUtime(
static int
TestReportNormalizePath(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
@@ -6516,7 +6631,7 @@ TestReportNormalizePath(
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ TCL_UNUSED(ClientData *))
{
const char *str = Tcl_GetString(pathPtr);
@@ -6545,7 +6660,7 @@ SimplePathInFilesystem(
static int
TestSimpleFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6561,7 +6676,7 @@ TestSimpleFilesystemObjCmd(
return TCL_ERROR;
}
if (boolVal) {
- res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
+ res = Tcl_FSRegister(interp, &simpleFilesystem);
msg = (res == TCL_OK) ? "registered" : "failed";
} else {
res = Tcl_FSUnregister(&simpleFilesystem);
@@ -6702,49 +6817,30 @@ 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 > (int)sizeof(buffer) - 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"testutfnext\" can only handle %d bytes",
(int)sizeof(buffer) - 4));
@@ -6754,13 +6850,6 @@ TestUtfNextCmd(
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 */
@@ -6792,7 +6881,7 @@ TestUtfNextCmd(
static int
TestUtfPrevCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6809,7 +6898,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) {
@@ -6832,7 +6921,7 @@ TestUtfPrevCmd(
static int
TestNumUtfCharsCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6842,7 +6931,7 @@ TestNumUtfCharsCmd(
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) {
@@ -6861,7 +6950,7 @@ TestNumUtfCharsCmd(
static int
TestFindFirstCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6883,7 +6972,7 @@ TestFindFirstCmd(
static int
TestFindLastCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6925,13 +7014,13 @@ TestFindLastCmd(
static int
TestcpuidCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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) {
@@ -6941,14 +7030,14 @@ TestcpuidCmd(
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
- status = TclWinCPUID((unsigned) index, regs);
+ status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operation not available", -1));
return status;
}
for (i=0 ; i<4 ; ++i) {
- regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
+ regsObjs[i] = Tcl_NewIntObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
@@ -6961,7 +7050,7 @@ TestcpuidCmd(
static int
TestHashSystemHashCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6973,7 +7062,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;
@@ -7038,15 +7126,13 @@ TestHashSystemHashCmd(
*/
static int
TestgetintCmd(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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;
@@ -7062,14 +7148,31 @@ TestgetintCmd(
}
}
+/*
+ * Used for determining sizeof(long) at script level.
+ */
+static int
+TestlongsizeCmd(
+ TCL_UNUSED(ClientData),
+ 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_NewIntObj((int)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),
@@ -7092,15 +7195,11 @@ NREUnwind_callback(
static int
TestNREUnwind(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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.
@@ -7114,10 +7213,10 @@ TestNREUnwind(
static int
TestNRELevels(
- ClientData dummy,
+ TCL_UNUSED(ClientData),
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;
@@ -7125,9 +7224,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;
@@ -7173,10 +7269,10 @@ TestNRELevels(
static int
TestconcatobjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
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;
@@ -7194,17 +7290,11 @@ TestconcatobjCmd(
list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
Tcl_ListObjLength(NULL, list1Ptr, &len);
- if (list1Ptr->bytes != NULL) {
- ckfree(list1Ptr->bytes);
- list1Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list1Ptr);
list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
Tcl_ListObjLength(NULL, list2Ptr, &len);
- if (list2Ptr->bytes != NULL) {
- ckfree(list2Ptr->bytes);
- list2Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list2Ptr);
/*
* Verify that concat'ing a list obj with one or more empty strings does
@@ -7459,6 +7549,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(ClientData),
+ 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(ClientData),
+ 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
@@ -7476,7 +7632,7 @@ TestconcatobjCmd(
static int
TestparseargsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
@@ -7509,8 +7665,8 @@ static int
InterpCmdResolver(
Tcl_Interp *interp,
const char *name,
- Tcl_Namespace *context,
- int flags,
+ TCL_UNUSED(Tcl_Namespace *),
+ TCL_UNUSED(int) /*flags*/,
Tcl_Command *rPtr)
{
Interp *iPtr = (Interp *) interp;
@@ -7578,7 +7734,7 @@ InterpCmdResolver(
*/
CallFrame *parentFramePtr = varFramePtr->callerPtr;
- char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
+ const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
@@ -7600,11 +7756,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.
@@ -7644,7 +7800,7 @@ MyCompiledVarFree(
}
#define TclVarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static Tcl_Var
MyCompiledVarFetch(
@@ -7693,14 +7849,14 @@ MyCompiledVarFetch(
static int
InterpCompiledVarResolver(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *name,
- int length,
- Tcl_Namespace *context,
+ TCL_UNUSED(int) /*length*/,
+ TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
- MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)ckalloc(sizeof(MyResolvedVarInfo));
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
@@ -7715,7 +7871,7 @@ InterpCompiledVarResolver(
static int
TestInterpResolverCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index ba1dda6..bfd0a45 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -18,9 +18,21 @@
# 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:
@@ -30,30 +42,21 @@ static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int 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[]);
+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_Interp *interp)
{
- register int i;
+ int i;
Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
@@ -91,7 +94,7 @@ int
TclObjTest_Init(
Tcl_Interp *interp)
{
- register int i;
+ int i;
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
* the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
@@ -146,7 +149,7 @@ TclObjTest_Init(
static int
TestbignumobjCmd(
- ClientData clientData, /* unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
@@ -345,7 +348,7 @@ TestbignumobjCmd(
static int
TestbooleanobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -385,9 +388,9 @@ TestbooleanobjCmd(
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get") == 0) {
@@ -410,9 +413,9 @@ TestbooleanobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
@@ -445,7 +448,7 @@ TestbooleanobjCmd(
static int
TestdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -563,7 +566,7 @@ TestdoubleobjCmd(
static int
TestindexobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -571,6 +574,7 @@ TestindexobjCmd(
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
+
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
@@ -594,7 +598,7 @@ TestindexobjCmd(
}
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);
@@ -616,29 +620,15 @@ TestindexobjCmd(
return TCL_ERROR;
}
- argv = ckalloc((objc-3) * sizeof(char *));
+ argv = (const char **)ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
- /*
- * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
- * that its address is different for each index object. If we accidently
- * 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", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
+ &index);
ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
@@ -666,13 +656,13 @@ TestindexobjCmd(
static int
TestintobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
- long longValue;
+ Tcl_WideInt wideValue;
const char *index, *subCmd, *string;
Tcl_Obj **varPtr;
@@ -727,7 +717,7 @@ TestintobjCmd(
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
}
- } else if (strcmp(subCmd, "setlong") == 0) {
+ } else if (strcmp(subCmd, "setint") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
@@ -737,33 +727,33 @@ TestintobjCmd(
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], intValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "setmaxlong") == 0) {
- long maxLong = LONG_MAX;
+ } else if (strcmp(subCmd, "setmax") == 0) {
+ Tcl_WideInt maxWide = WIDE_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], maxLong);
+ Tcl_SetWideIntObj(varPtr[varIndex], maxWide);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide));
}
- } else if (strcmp(subCmd, "ismaxlong") == 0) {
+ } else if (strcmp(subCmd, "ismax") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ((longValue == LONG_MAX)? "1" : "0"), -1);
+ ((wideValue == WIDE_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -796,9 +786,9 @@ TestintobjCmd(
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
+ Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
@@ -870,7 +860,7 @@ TestintobjCmd(
static int
TestlistobjCmd(
- ClientData clientData, /* Not used */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
@@ -967,7 +957,7 @@ TestlistobjCmd(
static int
TestobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1102,6 +1092,9 @@ TestobjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (!strcmp(typeName, "wideInt")) typeName = "int";
+#endif
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
@@ -1115,7 +1108,7 @@ TestobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -1129,6 +1122,11 @@ TestobjCmd(
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "int", -1);
+#endif
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
@@ -1171,7 +1169,7 @@ TestobjCmd(
static int
TeststringobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1184,8 +1182,8 @@ TeststringobjCmd(
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
- "set", "set2", "setlength", "maxchars", "getunicode",
- "appendself", "appendself2", NULL
+ "set", "set2", "setlength", "maxchars", "appendself",
+ "appendself2", NULL
};
if (objc < 3) {
@@ -1289,7 +1287,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
@@ -1343,20 +1341,14 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
- case 10: /* getunicode */
- if (objc != 3) {
- goto wrongNumArgs;
- }
- Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
- break;
- case 11: /* appendself */
+ case 10: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -1387,7 +1379,7 @@ TeststringobjCmd(
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
- case 12: /* appendself2 */
+ case 11: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index fba2844..09dfbef 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -45,13 +45,13 @@ typedef struct CmdTable {
* Declarations for functions defined in this file.
*/
-static int ProcBodyTestProcObjCmd(ClientData dummy,
+static int ProcBodyTestProcObjCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int ProcBodyTestCheckObjCmd(ClientData dummy,
+static int ProcBodyTestCheckObjCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
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
@@ -139,7 +139,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 +147,13 @@ RegisterCommand(
if (cmdTablePtr->exportIt) {
sprintf(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;
}
}
- sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName);
+ sprintf(buf, "%s::%s", namesp, cmdTablePtr->cmdName);
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
return TCL_OK;
}
@@ -228,7 +228,7 @@ ProcBodyTestInitInternal(
static int
ProcBodyTestProcObjCmd(
- ClientData dummy, /* context; not used */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
@@ -327,7 +327,7 @@ ProcBodyTestProcObjCmd(
static int
ProcBodyTestCheckObjCmd(
- ClientData dummy, /* context; not used */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
@@ -340,7 +340,7 @@ ProcBodyTestCheckObjCmd(
}
version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
strcmp(version, packageVersion) == 0));
return TCL_OK;
}
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 198fa6a..f22653a 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -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.
*/
@@ -88,13 +73,13 @@ Tcl_GetThreadData(
if (result == NULL) {
result = ckalloc(size);
- memset(result, 0, (size_t) size);
+ memset(result, 0, size);
TclThreadStorageKeySet(keyPtr, result);
}
#else /* TCL_THREADS */
if (*keyPtr == NULL) {
result = ckalloc(size);
- memset(result, 0, (size_t)size);
+ memset(result, 0, size);
*keyPtr = result;
RememberSyncObject(keyPtr, &keyRecord);
} else {
@@ -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
TclpMasterLock();
@@ -322,11 +308,12 @@ TclRememberCondition(
*----------------------------------------------------------------------
*/
+#undef Tcl_ConditionFinalize
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpMasterLock();
@@ -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 master cleanup.
*/
@@ -473,12 +462,10 @@ Tcl_ExitThread(
int status)
{
Tcl_FinalizeThread();
-#ifdef TCL_THREADS
TclpThreadExit(status);
-#endif
}
-#ifndef TCL_THREADS
+#if !TCL_THREADS
/*
*----------------------------------------------------------------------
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 2ee758e..eb8a35d 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -13,7 +13,7 @@
*/
#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
@@ -134,8 +134,8 @@ static void LockBucket(Cache *cachePtr, int bucket);
static void UnlockBucket(Cache *cachePtr, int bucket);
static void PutBlocks(Cache *cachePtr, int bucket, int numMove);
static int GetBlocks(Cache *cachePtr, int bucket);
-static Block * Ptr2Block(char *ptr);
-static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
+static Block * Ptr2Block(void *ptr);
+static void * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove);
static void PutObjs(Cache *fromPtr, int numMove);
@@ -162,7 +162,7 @@ static __thread Cache *tcachePtr;
#else
# define GETCACHE(cachePtr) \
do { \
- (cachePtr) = TclpGetAllocCache(); \
+ (cachePtr) = (Cache*)TclpGetAllocCache(); \
if ((cachePtr) == NULL) { \
(cachePtr) = GetCache(); \
} \
@@ -196,20 +196,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 +209,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,9 +246,9 @@ void
TclFreeAllocCache(
void *arg)
{
- Cache *cachePtr = arg;
+ Cache *cachePtr = (Cache*)arg;
Cache **nextPtrPtr;
- register unsigned int bucket;
+ unsigned int bucket;
/*
* Flush blocks.
@@ -308,13 +299,13 @@ TclFreeAllocCache(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
- register int bucket;
+ int bucket;
size_t size;
#ifndef __LP64__
@@ -346,7 +337,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 +378,7 @@ TclpAlloc(
void
TclpFree(
- char *ptr)
+ void *ptr)
{
Cache *cachePtr;
Block *blockPtr;
@@ -444,9 +435,9 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *ptr,
+ void *ptr,
unsigned int reqSize)
{
Cache *cachePtr;
@@ -500,7 +491,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;
}
@@ -546,8 +537,8 @@ TclpRealloc(
Tcl_Obj *
TclThreadAllocObj(void)
{
- register Cache *cachePtr;
- register Tcl_Obj *objPtr;
+ Cache *cachePtr;
+ Tcl_Obj *objPtr;
GETCACHE(cachePtr);
@@ -557,7 +548,7 @@ TclThreadAllocObj(void)
*/
if (cachePtr->numObjects == 0) {
- register int numMove;
+ int numMove;
Tcl_MutexLock(objLockPtr);
numMove = sharedPtr->numObjects;
@@ -572,7 +563,7 @@ 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);
}
@@ -591,7 +582,7 @@ TclThreadAllocObj(void)
*/
objPtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
@@ -718,7 +709,7 @@ MoveObjs(
Cache *toPtr,
int numMove)
{
- register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
+ Tcl_Obj *objPtr = fromPtr->firstObjPtr;
Tcl_Obj *fromFirstObjPtr = objPtr;
toPtr->numObjects += numMove;
@@ -730,9 +721,9 @@ MoveObjs(
*/
while (--numMove) {
- objPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ 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
@@ -775,7 +766,7 @@ PutObjs(
} else {
do {
lastPtr = firstPtr;
- firstPtr = firstPtr->internalRep.twoPtrValue.ptr1;
+ firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1;
} while (--keep > 0);
lastPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
@@ -813,13 +804,13 @@ PutObjs(
*----------------------------------------------------------------------
*/
-static char *
+static void *
Block2Ptr(
Block *blockPtr,
int bucket,
unsigned int reqSize)
{
- register void *ptr;
+ void *ptr;
blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC;
blockPtr->sourceBucket = bucket;
@@ -828,14 +819,14 @@ Block2Ptr(
#if RCHECK
((unsigned char *)(ptr))[reqSize] = MAGIC;
#endif
- return (char *) ptr;
+ return ptr;
}
static Block *
Ptr2Block(
- char *ptr)
+ void *ptr)
{
- register Block *blockPtr;
+ Block *blockPtr;
blockPtr = (((Block *) ptr) - 1);
if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) {
@@ -881,7 +872,7 @@ LockBucket(
static void
UnlockBucket(
- Cache *cachePtr,
+ TCL_UNUSED(Cache *),
int bucket)
{
Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
@@ -969,8 +960,8 @@ GetBlocks(
Cache *cachePtr,
int bucket)
{
- register Block *blockPtr;
- register int n;
+ Block *blockPtr;
+ int n;
/*
* First, atttempt to move blocks from the shared cache. Note the
@@ -1015,7 +1006,7 @@ GetBlocks(
}
if (cachePtr->buckets[bucket].numFree == 0) {
- register size_t size;
+ size_t size;
/*
* If no blocks could be moved from shared, first look for a larger
@@ -1024,7 +1015,7 @@ GetBlocks(
blockPtr = NULL;
n = NBUCKETS;
- size = 0; /* lint */
+ size = 0;
while (--n > bucket) {
if (cachePtr->buckets[n].numFree > 0) {
size = bucketInfo[n].blockSize;
@@ -1041,7 +1032,7 @@ GetBlocks(
if (blockPtr == NULL) {
size = MAXALLOC;
- blockPtr = TclpSysAlloc(size, 0);
+ blockPtr = (Block*)TclpSysAlloc(size, 0);
if (blockPtr == NULL) {
return 0;
}
@@ -1064,6 +1055,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 = 1 << (NBUCKETS - 1 - i);
+ bucketInfo[i].numMove = i < NBUCKETS - 1 ?
+ 1 << (NBUCKETS - 2 - i) : 1;
+ bucketInfo[i].lockPtr = TclpNewAllocMutex();
+ }
+ TclpInitAllocCache();
+}
/*
*----------------------------------------------------------------------
@@ -1122,7 +1147,7 @@ TclFinalizeThreadAlloc(void)
void
TclFinalizeThreadAllocThread(void)
{
- Cache *cachePtr = TclpGetAllocCache();
+ Cache *cachePtr = (Cache *)TclpGetAllocCache();
if (cachePtr != NULL) {
TclpFreeAllocCache(cachePtr);
}
@@ -1147,7 +1172,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 5c70a62..0aff0a7 100644
--- a/generic/tclThreadJoin.c
+++ b/generic/tclThreadJoin.c
@@ -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;
diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c
index 755a461..99e6bac 100644
--- a/generic/tclThreadStorage.c
+++ b/generic/tclThreadStorage.c
@@ -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 = TclpThreadGetMasterTSD(tsdMaster.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetMasterTSD(tsdMaster.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 = TclpThreadGetMasterTSD(tsdMaster.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetMasterTSD(tsdMaster.key);
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
if (tsdTablePtr == NULL) {
@@ -288,7 +288,7 @@ TclThreadStorageKeySet(
void
TclFinalizeThreadDataThread(void)
{
- TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetMasterTSD(tsdMaster.key);
if (tsdTablePtr != NULL) {
TSDTableDelete(tsdTablePtr);
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 35b3fc3..b1b64f4 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -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,7 +119,7 @@ static char *errorProcString;
TCL_DECLARE_MUTEX(threadMutex)
-static int ThreadObjCmd(ClientData clientData,
+static int ThreadObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int ThreadCreate(Tcl_Interp *interp, const char *script,
@@ -130,15 +130,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 +203,9 @@ TclThread_Init(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -435,7 +434,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 +490,6 @@ ThreadObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
@@ -508,7 +506,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 +554,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 +593,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);
@@ -654,9 +652,9 @@ ThreadErrorProc(
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ sprintf(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);
@@ -840,13 +838,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;
/*
@@ -1010,7 +1008,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 +1029,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 +1040,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 +1071,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 +1102,10 @@ ThreadFreeProc(
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
- ClientData clientData) /* dummy */
+ TCL_UNUSED(ClientData))
{
if (eventPtr->proc == ThreadEventProc) {
ckfree(((ThreadEvent *) eventPtr)->script);
@@ -1141,12 +1137,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 +1194,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 106e2f7..05a80b0 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -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,13 +211,13 @@ 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) {
- register TimerHandler *timerHandlerPtr;
+ TimerHandler *timerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
@@ -294,10 +294,10 @@ TclCreateAbsoluteTimerHandler(
Tcl_TimerProc *proc,
ClientData clientData)
{
- register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
+ TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
- timerHandlerPtr = ckalloc(sizeof(TimerHandler));
+ timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
@@ -355,7 +355,7 @@ Tcl_DeleteTimerHandler(
Tcl_TimerToken token) /* Result previously returned by
* Tcl_DeleteTimerHandler. */
{
- register TimerHandler *timerHandlerPtr, *prevPtr;
+ TimerHandler *timerHandlerPtr, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
if (token == NULL) {
@@ -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. */
{
@@ -621,11 +621,11 @@ Tcl_DoWhenIdle(
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- register IdleHandler *idlePtr;
+ IdleHandler *idlePtr;
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;
@@ -665,7 +665,7 @@ Tcl_CancelIdleCall(
Tcl_IdleProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- register IdleHandler *idlePtr, *prevPtr;
+ IdleHandler *idlePtr, *prevPtr;
IdleHandler *nextPtr;
ThreadSpecificData *tsdPtr = InitTimer();
@@ -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,7 +788,7 @@ Tcl_AfterObjCmd(
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
- int index;
+ int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
@@ -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,13 +893,13 @@ 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, (unsigned) length)) {
+ && !memcmp(command, tempCommand, length)) {
break;
}
}
@@ -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];
@@ -1045,11 +1038,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;
}
@@ -1066,16 +1054,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) {
@@ -1089,7 +1072,7 @@ AfterDelay(
return TCL_ERROR;
}
}
- Tcl_GetTime(&now);
+ Tcl_GetTime(&now);
} while (TCL_TIME_BEFORE(now, endTime));
return TCL_OK;
}
@@ -1166,7 +1149,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;
@@ -1264,14 +1247,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 2511e3a..9d6eb1c 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -23,20 +23,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)
@@ -48,128 +48,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)
@@ -178,96 +178,96 @@ 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)
}
# 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)
}
# 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 85b0b4b..b421cde 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -1,1122 +1,47 @@
-/* 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;
+#ifdef MP_NO_STDINT
+# ifdef HAVE_STDINT_H
+# include <stdint.h>
#else
-typedef unsigned long long private_mp_word;
-#endif
-#define MP_WORD_DECLARED
-#endif
-
-# ifdef MP_31BIT
-/*
- * This is an extension that uses 31-bit digits.
- * Please be aware that not all functions support this size, especially s_mp_mul_digs_fast
- * will be reduced to work on small numbers only:
- * Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT.
- */
-# define MP_DIGIT_BIT 31
-# else
-/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
-# define MP_DIGIT_BIT 28
-# define MP_28BIT
+# 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 */
+# 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)))
-# 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(x) __declspec(deprecated("replaced by " #x))
-# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
-#else
-# define MP_DEPRECATED(s)
-# 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;
-*/
+#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
+# include "tommath.h"
#endif
-/*
-unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
-*/
-/*
-Tcl_WideUInt mp_get_mag_ull(const mp_int *a) MP_WUR;
-*/
-
-/* get integer, set integer (long) */
-/*
-long mp_get_l(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_l(mp_int *a, long b);
-*/
-/*
-mp_err mp_init_l(mp_int *a, long b) MP_WUR;
-*/
-
-/* get integer, set integer (unsigned long) */
-#define mp_get_ul(a) ((unsigned long)mp_get_l(a))
-/*
-void mp_set_ul(mp_int *a, unsigned long b);
-*/
-/*
-mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
-*/
-
-/* get integer, set integer (Tcl_WideInt) */
-/*
-Tcl_WideInt mp_get_ll(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_ll(mp_int *a, Tcl_WideInt b);
-*/
-/*
-mp_err mp_init_ll(mp_int *a, Tcl_WideInt b) MP_WUR;
-*/
-
-/* get integer, set integer (Tcl_WideUInt) */
-#define mp_get_ull(a) ((Tcl_WideUInt)mp_get_ll(a))
-/*
-void mp_set_ull(mp_int *a, Tcl_WideUInt b);
-*/
-/*
-mp_err mp_init_ull(mp_int *a, Tcl_WideUInt b) MP_WUR;
-*/
-
-/* set to single unsigned digit, up to MP_DIGIT_MAX */
-/*
-void mp_set(mp_int *a, mp_digit b);
-*/
-/*
-mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (deprecated) */
-/*
-MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) Tcl_WideUInt mp_get_long_long(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
-*/
-/*
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
-*/
-/*
-MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, Tcl_WideUInt b);
-*/
-/*
-MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
-*/
-
-/* copy, b = a */
-/*
-mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* inits and copies, a = b */
-/*
-mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* trim unused digits */
-/*
-void mp_clamp(mp_int *a);
-*/
-
-/* export binary data */
-/*
-MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
- int endian, size_t nails, const mp_int *op) MP_WUR;
-*/
-
-/* import binary data */
-/*
-MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order,
- size_t size, int endian, size_t nails,
- const void *op) MP_WUR;
-*/
-
-/* unpack binary data */
-/*
-mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian,
- size_t nails, const void *op) MP_WUR;
-*/
-
-/* pack binary data */
-/*
-size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
- mp_endian endian, size_t nails, const mp_int *op) MP_WUR;
-*/
-
-/* ---> digit manipulation <--- */
-
-/* right shift by "b" digits */
-/*
-void mp_rshd(mp_int *a, int b);
-*/
-
-/* left shift by "b" digits */
-/*
-mp_err mp_lshd(mp_int *a, int b) MP_WUR;
-*/
-
-/* c = a / 2**b, implemented as c = a >> b */
-/*
-mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* b = a/2 */
-/*
-mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* a/3 => 3c + d == a */
-/*
-mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR;
-*/
-
-/* c = a * 2**b, implemented as c = a << b */
-/*
-mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* b = a*2 */
-/*
-mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* c = a mod 2**b */
-/*
-mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* computes a = 2**b */
-/*
-mp_err mp_2expt(mp_int *a, int b) MP_WUR;
-*/
-
-/* Counts the number of lsbs which are zero before the first zero bit */
-/*
-int mp_cnt_lsb(const mp_int *a) MP_WUR;
-*/
-
-/* I Love Earth! */
-
-/* makes a pseudo-random mp_int of a given size */
-/*
-mp_err mp_rand(mp_int *a, int digits) MP_WUR;
-*/
-/* makes a pseudo-random small int of a given size */
-/*
-MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR;
-*/
-/* use custom random data source instead of source provided the platform */
-/*
-void mp_rand_source(mp_err(*source)(void *out, size_t size));
-*/
-
-#ifdef MP_PRNG_ENABLE_LTM_RNG
-/* A last resort to provide random data on systems without any of the other
- * implemented ways to gather entropy.
- * It is compatible with `rng_get_bytes()` from libtomcrypt so you could
- * provide that one and then set `ltm_rng = rng_get_bytes;` */
-extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
-extern void (*ltm_rng_callback)(void);
-#endif
-
-/* ---> binary operations <--- */
-
-/* Checks the bit at position b and returns MP_YES
- * if the bit is 1, MP_NO if it is 0 and MP_VAL
- * in case of error
- */
-/*
-MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR;
-*/
-
-/* c = a XOR b (two complement) */
-/*
-MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a OR b (two complement) */
-/*
-MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a AND b (two complement) */
-/*
-MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* b = ~a (bitwise not, two complement) */
-/*
-mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* right shift with sign extension */
-/*
-MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* ---> Basic arithmetic <--- */
-
-/* b = -a */
-/*
-mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* b = |a| */
-/*
-mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* compare a to b */
-/*
-mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* compare |a| to |b| */
-/*
-mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* c = a + b */
-/*
-mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a - b */
-/*
-mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a * b */
-/*
-mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* b = a*a */
-/*
-mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* a/b => cb + d == a */
-/*
-mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* c = a mod b, 0 <= c < b */
-/*
-mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* Increment "a" by one like "a++". Changes input! */
-/*
-mp_err mp_incr(mp_int *a) MP_WUR;
-*/
-
-/* Decrement "a" by one like "a--". Changes input! */
-/*
-mp_err mp_decr(mp_int *a) MP_WUR;
-*/
-
-/* ---> single digit functions <--- */
-
-/* compare against a single digit */
-/*
-mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR;
-*/
-
-/* c = a + b */
-/*
-mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* c = a - b */
-/*
-mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* c = a * b */
-/*
-mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* a/b => cb + d == a */
-/*
-mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR;
-*/
-
-/* c = a mod b, 0 <= c < b */
-/*
-mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR;
-*/
-
-/* ---> number theory <--- */
-
-/* d = a + b (mod c) */
-/*
-mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* d = a - b (mod c) */
-/*
-mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* d = a * b (mod c) */
-/*
-mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* c = a * a (mod b) */
-/*
-mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = 1/a (mod b) */
-/*
-mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = (a, b) */
-/*
-mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* produces value such that U1*a + U2*b = U3 */
-/*
-mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR;
-*/
-
-/* c = [a, b] or (a*b)/(a, b) */
-/*
-mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* finds one of the b'th root of a, such that |c|**b <= |a|
- *
- * returns error if a < 0 and b is even
- */
-/*
-mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
-*/
-
-/* special sqrt algo */
-/*
-mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR;
-*/
-
-/* special sqrt (mod prime) */
-/*
-mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR;
-*/
-
-/* is number a square? */
-/*
-mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR;
-*/
-
-/* computes the jacobi c = (a | n) (or Legendre if b is prime) */
-/*
-MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR;
-*/
-
-/* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
-/*
-mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR;
-*/
-
-/* used to setup the Barrett reduction for a given modulus b */
-/*
-mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* Barrett Reduction, computes a (mod b) with a precomputed value c
- *
- * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
- * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
- */
-/*
-mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR;
-*/
-
-/* setups the montgomery reduction */
-/*
-mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR;
-*/
-
-/* computes a = B**n mod b without division or multiplication useful for
- * normalizing numbers in a Montgomery system.
- */
-/*
-mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* computes x/R == x (mod N) via Montgomery Reduction */
-/*
-mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
-*/
-
-/* returns 1 if a is a valid DR modulus */
-/*
-mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR;
-*/
-
-/* sets the value of "d" required for mp_dr_reduce */
-/*
-void mp_dr_setup(const mp_int *a, mp_digit *d);
-*/
-
-/* reduces a modulo n using the Diminished Radix method */
-/*
-mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR;
-*/
-
-/* returns true if a can be reduced with mp_reduce_2k */
-/*
-mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR;
-*/
-
-/* determines k value for 2k reduction */
-/*
-mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR;
-*/
-
-/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-/*
-mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR;
-*/
-
-/* returns true if a can be reduced with mp_reduce_2k_l */
-/*
-mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR;
-*/
-
-/* determines k value for 2k reduction */
-/*
-mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR;
-*/
-
-/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-/*
-mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR;
-*/
-
-/* Y = G**X (mod P) */
-/*
-mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR;
-*/
-
-/* ---> Primes <--- */
-
-/* number of primes */
-#ifdef MP_8BIT
-# define PRIVATE_MP_PRIME_TAB_SIZE 31
-#else
-# define PRIVATE_MP_PRIME_TAB_SIZE 256
-#endif
-#define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE)
-
-/* table of first PRIME_SIZE primes */
-#if defined(BUILD_tcl) || !defined(_WIN32)
-MODULE_SCOPE const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
-#endif
-
-/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
-/*
-MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Fermat test of "a" using base "b".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Miller-Rabin test of "a" using base "b".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
-*/
-
-/* This gives [for a given bit size] the number of trials required
- * such that Miller-Rabin gives a prob of failure lower than 2^-96
- */
-/*
-int mp_prime_rabin_miller_trials(int size) MP_WUR;
-*/
-
-/* performs one strong Lucas-Selfridge test of "a".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Frobenius test of "a" as described by Paul Underwood.
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
-*/
-
-/* performs t random rounds of Miller-Rabin on "a" additional to
- * bases 2 and 3. Also performs an initial sieve of trial
- * division. Determines if "a" is prime with probability
- * of error no more than (1/4)**t.
- * Both a strong Lucas-Selfridge to complete the BPSW test
- * and a separate Frobenius test are available at compile time.
- * With t<0 a deterministic test is run for primes up to
- * 318665857834031151167461. With t<13 (abs(t)-13) additional
- * tests with sequential small primes are run starting at 43.
- * Is Fips 186.4 compliant if called with t as computed by
- * mp_prime_rabin_miller_trials();
- *
- * Sets result to 1 if probably prime, 0 otherwise
- */
-/*
-mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR;
-*/
-
-/* finds the next prime after the number "a" using "t" trials
- * of Miller-Rabin.
- *
- * bbs_style = 1 means the prime must be congruent to 3 mod 4
- */
-/*
-mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
-*/
-
-/* makes a truly random prime of a given size (bytes),
- * call with bbs = 1 if you want it to be congruent to 3 mod 4
- *
- * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
- * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
- * so it can be NULL
- *
- * The prime generated will be larger than 2^(8*size).
- */
-#define mp_prime_random(a, t, size, bbs, cb, dat) (MP_DEPRECATED_PRAGMA("mp_prime_random has been deprecated, use mp_prime_rand instead") mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?MP_PRIME_BBS:0, cb, dat))
-
-/* makes a truly random prime of a given size (bits),
- *
- * Flags are as follows:
- *
- * MP_PRIME_BBS - make prime congruent to 3 mod 4
- * MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS)
- * MP_PRIME_2MSB_ON - make the 2nd highest bit one
- *
- * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
- * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
- * so it can be NULL
- *
- */
-/*
-MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
- private_mp_prime_callback cb, void *dat) MP_WUR;
-*/
-/*
-mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
-*/
-
-/* Integer logarithm to integer base */
-/*
-mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) MP_WUR;
-*/
-
-/* c = a**b */
-/*
-mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
-*/
-
-/* ---> radix conversion <--- */
-/*
-int mp_count_bits(const mp_int *a) MP_WUR;
-*/
-
-
-/*
-MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
-*/
-
-/*
-MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
-*/
-
-/*
-size_t mp_ubin_size(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
-*/
-
-/*
-size_t mp_sbin_size(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
-*/
-
-/*
-mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR;
-*/
-/*
-mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR;
-*/
-/*
-mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR;
-*/
-
-#ifndef MP_NO_FILE
-/*
-mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR;
-*/
-/*
-mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
-*/
-#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 6991643..1427e8b 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,68 +43,93 @@
/* 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
+# define MODULE_SCOPE extern
+#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);
+#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_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
@@ -114,8 +140,7 @@
#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_unsigned_bin_size
-#define mp_unsigned_bin_size(a) ((int)TclBN_mp_unsigned_bin_size(a))
+#define mp_ubin_size TclBN_mp_ubin_size
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
@@ -123,13 +148,20 @@
#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") TclBN_mp_init_u64(a,(unsigned int)(b)))
+#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),((unsigned int)(b))),MP_OKAY))
+#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),(long)(b)),MP_OKAY))
+#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (TclBN_mp_set_u64((a),(b)),MP_OKAY))
+#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)TclBN_mp_ubin_size(mp))
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
@@ -159,18 +191,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 */
@@ -178,267 +210,288 @@ 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);
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* 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;
/* Slot 77 is reserved */
/* 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 */
+ 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 */
void (*reserved71)(void);
void (*reserved72)(void);
- 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 */
+ 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 */
void (*reserved77)(void);
- 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 */
+ 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;
@@ -491,8 +544,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 \
@@ -547,18 +600,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 \
@@ -575,26 +628,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 */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
#define TclBN_mp_tc_and \
@@ -617,15 +670,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"); \
} \
@@ -634,7 +705,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"); \
} \
@@ -643,27 +714,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..60ed123 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -13,7 +13,7 @@
*/
#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..7bebe12 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -12,6 +12,7 @@
*/
#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 882dc39..e05fa69 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -52,7 +52,7 @@ 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. */
@@ -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
@@ -136,14 +135,14 @@ static int StringTraceProc(ClientData clientData,
static void StringTraceDeleteProc(ClientData clientData);
static void DisposeTraceResult(int flags, char *result);
static int TraceVarEx(Tcl_Interp *interp, const char *part1,
- const char *part2, register VarTrace *tracePtr);
+ const char *part2, VarTrace *tracePtr);
/*
* The following structure holds the client data for string-based
* trace procs
*/
-typedef struct StringTraceData {
+typedef struct {
ClientData clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
@@ -182,10 +181,9 @@ typedef struct StringTraceData {
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_TraceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -280,7 +278,7 @@ Tcl_TraceObjCmd(
opsList = Tcl_NewObj();
Tcl_IncrRefCount(opsList);
- flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
+ flagOps = TclGetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
@@ -325,7 +323,7 @@ Tcl_TraceObjCmd(
resultListPtr = Tcl_NewObj();
name = Tcl_GetString(objv[2]);
FOREACH_VAR_TRACE(interp, name, clientData) {
- TraceVarInfo *tvarPtr = clientData;
+ TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *q = ops;
pairObjPtr = Tcl_NewListObj(0, NULL);
@@ -466,11 +464,11 @@ TraceExecutionObjCmd(
break;
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
+ command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- TraceCommandInfo *tcmdPtr = ckalloc(
- TclOffset(TraceCommandInfo, command) + 1 + length);
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
+ offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -509,7 +507,7 @@ TraceExecutionObjCmd(
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* In checking the 'flags' field we must remove any extraneous
@@ -578,7 +576,7 @@ TraceExecutionObjCmd(
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
@@ -703,11 +701,11 @@ TraceCommandObjCmd(
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
+ command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- TraceCommandInfo *tcmdPtr = ckalloc(
- TclOffset(TraceCommandInfo, command) + 1 + length);
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
+ offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -742,7 +740,7 @@ TraceCommandObjCmd(
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
@@ -781,7 +779,7 @@ TraceCommandObjCmd(
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
@@ -906,11 +904,11 @@ TraceVariableObjCmd(
break;
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
+ command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- CombinedTraceVarInfo *ctvarPtr = ckalloc(
- TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+ CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc(
+ offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
@@ -940,7 +938,7 @@ TraceVariableObjCmd(
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
- TraceVarInfo *tvarPtr = clientData;
+ TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags
@@ -971,7 +969,7 @@ TraceVariableObjCmd(
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr;
- TraceVarInfo *tvarPtr = clientData;
+ TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
@@ -1040,8 +1038,7 @@ ClientData
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
* this function, so this call will return the
@@ -1049,7 +1046,7 @@ Tcl_CommandTraceInfo(
* call will return the first trace. */
{
Command *cmdPtr;
- register CommandTrace *tracePtr;
+ CommandTrace *tracePtr;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
@@ -1114,7 +1111,7 @@ Tcl_TraceCommand(
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
- register CommandTrace *tracePtr;
+ CommandTrace *tracePtr;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
@@ -1126,7 +1123,7 @@ Tcl_TraceCommand(
* Set up trace information.
*/
- tracePtr = ckalloc(sizeof(CommandTrace));
+ tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags &
@@ -1177,7 +1174,7 @@ Tcl_UntraceCommand(
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
- register CommandTrace *tracePtr;
+ CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
@@ -1279,7 +1276,6 @@ Tcl_UntraceCommand(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
TraceCommandProc(
ClientData clientData, /* Information about the command trace. */
@@ -1291,7 +1287,7 @@ TraceCommandProc(
int flags) /* OR-ed bits giving operation and other
* information. */
{
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int code;
Tcl_DString cmd;
@@ -1423,8 +1419,7 @@ 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(int) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
@@ -1469,7 +1464,7 @@ TclCheckExecutionTraces(
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
- TraceCommandInfo *tcmdPtr = tracePtr->clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
@@ -1610,7 +1605,7 @@ TclCheckInterpTraces(
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
- TraceCommandInfo *tcmdPtr = tracePtr->clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
@@ -1672,13 +1667,13 @@ TclCheckInterpTraces(
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
- register Trace *tracePtr, /* Describes the trace function to call. */
+ Trace *tracePtr, /* Describes the trace function to call. */
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
* source. */
- register int objc, /* Number of arguments for the command. */
+ int objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
@@ -1689,8 +1684,8 @@ CallTraceFunction(
* Copy the command characters into a new string.
*/
- commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1);
- memcpy(commandCopy, command, (size_t) numChars);
+ commandCopy = (char *)TclStackAlloc(interp, numChars + 1);
+ memcpy(commandCopy, command, numChars);
commandCopy[numChars] = '\0';
/*
@@ -1725,7 +1720,7 @@ static void
CommandObjTraceDeleted(
ClientData clientData)
{
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
@@ -1763,13 +1758,13 @@ TraceExecutionProc(
Tcl_Interp *interp,
int level,
const char *command,
- Tcl_Command cmdInfo,
+ TCL_UNUSED(Tcl_Command),
int objc,
struct Tcl_Obj *const objv[])
{
int call = 0;
Interp *iPtr = (Interp *) interp;
- TraceCommandInfo *tcmdPtr = clientData;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
@@ -1920,10 +1915,10 @@ TraceExecutionProc(
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
- register unsigned len = strlen(command) + 1;
+ unsigned len = strlen(command) + 1;
tcmdPtr->startLevel = level;
- tcmdPtr->startCmd = ckalloc(len);
+ tcmdPtr->startCmd = (char *)ckalloc(len);
memcpy(tcmdPtr->startCmd, command, len);
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
@@ -1964,7 +1959,6 @@ TraceExecutionProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static char *
TraceVarProc(
ClientData clientData, /* Information about the variable trace. */
@@ -1975,7 +1969,7 @@ TraceVarProc(
int flags) /* OR-ed bits giving operation and other
* information. */
{
- TraceVarInfo *tvarPtr = clientData;
+ TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
@@ -2065,7 +2059,7 @@ TraceVarProc(
}
}
if (destroy && result != NULL) {
- register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
+ Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
@@ -2142,8 +2136,8 @@ Tcl_CreateObjTrace(
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
- register Trace *tracePtr;
- register Interp *iPtr = (Interp *) interp;
+ Trace *tracePtr;
+ Interp *iPtr = (Interp *) interp;
/*
* Test if this trace allows inline compilation of commands.
@@ -2167,7 +2161,7 @@ Tcl_CreateObjTrace(
iPtr->tracesForbiddingInline++;
}
- tracePtr = ckalloc(sizeof(Trace));
+ tracePtr = (Trace *)ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
@@ -2230,7 +2224,7 @@ Tcl_CreateTrace(
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
- StringTraceData *data = ckalloc(sizeof(StringTraceData));
+ StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
@@ -2264,7 +2258,7 @@ StringTraceProc(
int objc,
Tcl_Obj *const *objv)
{
- StringTraceData *data = clientData;
+ StringTraceData *data = (StringTraceData *)clientData;
Command *cmdPtr = (Command *) commandInfo;
const char **argv; /* Args to pass to string trace proc */
int i;
@@ -2275,7 +2269,7 @@ StringTraceProc(
*/
argv = (const char **) TclStackAlloc(interp,
- (unsigned) ((objc + 1) * sizeof(const char *)));
+ (objc + 1) * sizeof(const char *));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
@@ -2342,7 +2336,7 @@ Tcl_DeleteTrace(
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
- register Trace **tracePtr2 = &iPtr->tracePtr;
+ Trace **tracePtr2 = &iPtr->tracePtr;
ActiveInterpTrace *activePtr;
/*
@@ -2534,7 +2528,7 @@ TclCheckArrayTraces(
int
TclObjCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
- register Var *arrayPtr, /* Pointer to array variable that contains the
+ Var *arrayPtr, /* Pointer to array variable that contains the
* variable, or NULL if the variable isn't an
* element of an array. */
Var *varPtr, /* Variable whose traces are to be invoked. */
@@ -2565,10 +2559,13 @@ TclObjCallVarTraces(
leaveErrMsg);
}
+#undef TCL_INTERP_DESTROYED
+#define TCL_INTERP_DESTROYED 0x100
+
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
- register Var *arrayPtr, /* Pointer to array variable that contains the
+ Var *arrayPtr, /* Pointer to array variable that contains the
* variable, or NULL if the variable isn't an
* element of an array. */
Var *varPtr, /* Variable whose traces are to be invoked. */
@@ -2581,7 +2578,7 @@ TclCallVarTraces(
* error, then leave an error message and
* stack trace information in *iPTr. */
{
- register VarTrace *tracePtr;
+ VarTrace *tracePtr;
ActiveVarTrace active;
char *result;
const char *openParen, *p;
@@ -2662,7 +2659,7 @@ TclCallVarTraces(
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
active.varPtr = arrayPtr;
- for (tracePtr = Tcl_GetHashValue(hPtr);
+ for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
@@ -2706,7 +2703,7 @@ TclCallVarTraces(
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
- for (tracePtr = Tcl_GetHashValue(hPtr);
+ for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
@@ -2862,6 +2859,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
@@ -2877,6 +2875,7 @@ Tcl_UntraceVar(
{
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2909,7 +2908,7 @@ Tcl_UntraceVar2(
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
- register VarTrace *tracePtr;
+ VarTrace *tracePtr;
VarTrace *prevPtr, *nextPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
@@ -2942,7 +2941,7 @@ Tcl_UntraceVar2(
flags &= flagMask;
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
- for (tracePtr = Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
+ for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
goto updateFlags;
@@ -3031,6 +3030,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
@@ -3048,6 +3048,7 @@ Tcl_VarTraceInfo(
return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
prevClientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3099,7 +3100,7 @@ Tcl_VarTraceInfo2(
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
if (hPtr) {
- register VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
+ VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (prevClientData != NULL) {
for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
@@ -3140,6 +3141,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_TraceVar
int
Tcl_TraceVar(
@@ -3157,6 +3159,7 @@ Tcl_TraceVar(
{
return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3195,10 +3198,10 @@ Tcl_TraceVar2(
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
- register VarTrace *tracePtr;
+ VarTrace *tracePtr;
int result;
- tracePtr = ckalloc(sizeof(VarTrace));
+ tracePtr = (VarTrace *)ckalloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags;
@@ -3240,7 +3243,7 @@ TraceVarEx(
const char *part2, /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
- register VarTrace *tracePtr)/* Structure containing flags, traceProc and
+ VarTrace *tracePtr)/* Structure containing flags, traceProc and
* clientData fields. Others should be left
* blank. Will be ckfree()d (eventually) if
* this function returns TCL_OK, and up to
@@ -3292,7 +3295,7 @@ TraceVarEx(
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
- tracePtr->nextPtr = Tcl_GetHashValue(hPtr);
+ tracePtr->nextPtr = (VarTrace *)Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, tracePtr);
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 5ae977a..11bde5c 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -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.
*/
@@ -64,8 +64,10 @@ 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,
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,
- 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,
+/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
+ 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,
+ 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
@@ -75,7 +77,7 @@ static const unsigned char totalBytes[256] = {
#endif
1,1,1,1,1,1,1,1,1,1,1
};
-
+
static const unsigned char complete[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,
@@ -99,15 +101,12 @@ static const unsigned char complete[256] = {
* 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".
*
@@ -120,8 +119,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)) {
@@ -130,11 +129,9 @@ UtfCount(
if (ch <= 0x7FF) {
return 2;
}
-#if TCL_UTF_MAX > 3
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
-#endif
return 3;
}
@@ -172,13 +169,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
@@ -207,6 +199,19 @@ Invalid(
* Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
*
+ * Special handling of Surrogate pairs is handled as follows:
+ * When this function is called for ch being a high surrogate,
+ * the first byte of the 4-byte UTF-8 sequence is produced and
+ * the function returns 1. Calling the function again with a
+ * low surrogate, the remaining 3 bytes of the 4-byte UTF-8
+ * sequence is produced, and the function returns 3. The buffer
+ * is used to remember the high surrogate between the two calls.
+ *
+ * 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 will produce a 3-byte UTF-8 sequence
+ * representing the high surrogate.
+ *
* Results:
* The return values is the number of bytes in the buffer that were
* consumed.
@@ -224,7 +229,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;
@@ -237,7 +242,6 @@ Tcl_UniCharToUtf(
return 2;
}
if (ch <= 0xFFFF) {
-#if TCL_UTF_MAX > 3
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x0400) {
/* Low surrogate */
@@ -259,11 +263,8 @@ Tcl_UniCharToUtf(
return 1;
}
}
-#endif
goto three;
}
-
-#if TCL_UTF_MAX > 3
if (ch <= 0x10FFFF) {
buf[3] = (char) ((ch | 0x80) & 0xBF);
buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
@@ -281,7 +282,6 @@ Tcl_UniCharToUtf(
buf[-1] = (char) ((ch >> 12) | 0xE0);
return 2;
}
-#endif
}
ch = 0xFFFD;
@@ -310,25 +310,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;
@@ -342,6 +352,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;
+}
/*
*---------------------------------------------------------------------------
*
@@ -377,27 +440,120 @@ Tcl_UniCharToUtfDString(
*---------------------------------------------------------------------------
*/
+static const unsigned short cp1252[32] = {
+ 0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
+ 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
+ 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
+ 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
+};
+
+#undef Tcl_UtfToUniChar
int
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
- Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by
+ int *chPtr)/* Filled with the Unicode character represented by
* the UTF-8 string. */
{
- Tcl_UniChar byte;
+ int byte;
+
+ /*
+ * Unroll 1 to 4 byte UTF-8 sequences.
+ */
+
+ byte = *((unsigned char *) src);
+ if (byte < 0xC0) {
+ /*
+ * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
+ * characters representing themselves.
+ */
+
+ if ((unsigned)(byte-0x80) < (unsigned)0x20) {
+ *chPtr = cp1252[byte-0x80];
+ } else {
+ *chPtr = byte;
+ }
+ return 1;
+ } else if (byte < 0xE0) {
+ if ((src[1] & 0xC0) == 0x80) {
+ /*
+ * Two-byte-character lead-byte followed by a trail-byte.
+ */
+
+ *chPtr = (((byte & 0x1F) << 6) | (src[1] & 0x3F));
+ if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) {
+ return 2;
+ }
+ }
+
+ /*
+ * A two-byte-character lead-byte not followed by trail-byte
+ * represents itself.
+ */
+ } else if (byte < 0xF0) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
+ /*
+ * Three-byte-character lead byte followed by two trail bytes.
+ */
+
+ *chPtr = (((byte & 0x0F) << 12)
+ | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F));
+ if (*chPtr > 0x7FF) {
+ return 3;
+ }
+ }
+
+ /*
+ * A three-byte-character lead-byte not followed by two trail-bytes
+ * represents itself.
+ */
+ }
+ else if (byte < 0xF5) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
+ /*
+ * Four-byte-character lead byte followed by three trail bytes.
+ */
+ *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
+ | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
+ if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
+ return 4;
+ }
+ }
+
+ /*
+ * A four-byte-character lead-byte not followed by three trail-bytes
+ * represents itself.
+ */
+ }
+
+ *chPtr = byte;
+ return 1;
+}
+
+int
+Tcl_UtfToChar16(
+ const char *src, /* The UTF-8 string. */
+ unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
+ * the UTF-8 string. This could be a surrogate too. */
+{
+ unsigned short byte;
/*
- * Unroll 1 to 3 (or 4) byte UTF-8 sequences.
+ * Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = UCHAR(*src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
- * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
-#if TCL_UTF_MAX <= 4
/* If *chPtr contains a high surrogate (produced by a previous
* Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation
* bytes, then we must produce a follow-up low surrogate. We only
@@ -410,8 +566,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 ((src[1] & 0xC0) == 0x80) {
@@ -453,7 +612,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) {
@@ -462,15 +620,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
}
/*
@@ -501,7 +650,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
@@ -510,7 +660,7 @@ Tcl_UtfToUniCharDString(
* appended to this previously initialized
* DString. */
{
- Tcl_UniChar ch = 0, *w, *wString;
+ int ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
@@ -518,6 +668,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);
}
@@ -530,20 +683,77 @@ Tcl_UtfToUniCharDString(
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
- oldLength + ((length + 1) * sizeof(Tcl_UniChar)));
- wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
+ oldLength + ((length + 1) * sizeof(int)));
+ wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
- optPtr = endPtr - TCL_UTF_MAX;
+ optPtr = endPtr - 4;
while (p <= optPtr) {
- p += TclUtfToUniChar(p, &ch);
+ p += TclUtfToUCS4(p, &ch);
+ *w++ = ch;
+ }
+ while ((p < endPtr) && TclUCS4Complete(p, endPtr-p)) {
+ p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
- if (Tcl_UtfCharComplete(p, endPtr-p)) {
- p += TclUtfToUniChar(p, &ch);
+ *w++ = UCHAR(*p++);
+ }
+ *w = '\0';
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((char *) w - (char *) wString));
+
+ return wString;
+}
+
+unsigned short *
+Tcl_UtfToChar16DString(
+ const char *src, /* UTF-8 string to convert to Unicode. */
+ int length, /* Length of UTF-8 string in bytes, or -1 for
+ * strlen(). */
+ Tcl_DString *dsPtr) /* Unicode representation of string is
+ * appended to this previously initialized
+ * DString. */
+{
+ unsigned short ch = 0, *w, *wString;
+ const char *p;
+ int oldLength;
+ /* Pointer to the end of string. Never read endPtr[0] */
+ const char *endPtr = src + length;
+ /* Pointer to last byte where optimization still can be used */
+ const char *optPtr = endPtr - TCL_UTF_MAX;
+
+ if (src == NULL) {
+ return NULL;
+ }
+ if (length < 0) {
+ length = strlen(src);
+ }
+
+ /*
+ * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
+ * bytes.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((length + 1) * sizeof(unsigned short)));
+ wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ p = src;
+ endPtr = src + length;
+ optPtr = endPtr - 3;
+ while (p <= optPtr) {
+ p += Tcl_UtfToChar16(p, &ch);
+ *w++ = ch;
+ }
+ while (p < endPtr) {
+ if (TclChar16Complete(p, endPtr-p)) {
+ p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
} else {
*w++ = UCHAR(*p++);
@@ -759,6 +969,13 @@ Tcl_UtfNext(
int left;
const char *next;
+ if (((*src) & 0xC0) == 0x80) {
+ if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) {
+ ++src;
+ }
+ return src;
+ }
+
left = totalBytes[UCHAR(*src)];
next = src + 1;
while (--left) {
@@ -847,7 +1064,7 @@ Tcl_UtfPrev(
* it (the fallback) is correct.
*/
- || (trailBytesSeen >= totalBytes[byte])) {
+ || (trailBytesSeen >= complete[byte])) {
/*
* That is, (1 + trailBytesSeen > needed).
* We've examined more bytes than needed to complete
@@ -888,15 +1105,19 @@ Tcl_UtfPrev(
/* Continue the search backwards... */
look--;
- } while (trailBytesSeen < 3);
+ } while (trailBytesSeen < TCL_UTF_MAX);
/*
- * We've seen 3 trail bytes, so we know there will not be a
+ * We've seen TCL_UTF_MAX trail bytes, so we know there will not be a
* properly formed byte sequence to find, and we can stop looking,
- * accepting the fallback.
+ * accepting the fallback (for TCL_UTF_MAX > 3) or just go back as
+ * far as we can.
*/
-
+#if TCL_UTF_MAX > 3
return fallback;
+#else
+ return src - TCL_UTF_MAX;
+#endif
}
/*
@@ -904,7 +1125,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:
@@ -916,17 +1137,29 @@ 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;
+ int i = 0;
- while (index-- >= 0) {
- src += TclUtfToUniChar(src, &ch);
+ if (index < 0) {
+ return -1;
}
- return ch;
+ while (index-- > 0) {
+ i = TclUtfToUniChar(src, &ch);
+ src += i;
+ }
+#if TCL_UTF_MAX <= 3
+ if ((ch >= 0xD800) && (i < 3)) {
+ /* Index points at character following high Surrogate */
+ return -1;
+ }
+#endif
+ TclUtfToUCS4(src, &i);
+ return i;
}
/*
@@ -935,7 +1168,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 <= 3, characters > U+FFFF count as
+ * 2 positions, but then the pointer should never be placed between
+ * the two positions.
*
* Results:
* As above.
@@ -958,7 +1193,7 @@ Tcl_UtfAtIndex(
len = TclUtfToUniChar(src, &ch);
src += len;
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (len < 3)) {
/* Index points at character following high Surrogate */
src += TclUtfToUniChar(src, &ch);
@@ -976,7 +1211,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.
@@ -1053,7 +1288,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
@@ -1061,11 +1296,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;
}
@@ -1106,7 +1341,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
@@ -1114,11 +1349,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;
}
@@ -1162,13 +1397,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;
}
@@ -1177,14 +1412,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;
}
@@ -1280,13 +1515,13 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
- if (((ch1 & ~0x3FF) == 0xD800)) {
- if ((ch2 & ~0x3FF) != 0xD800) {
+ if (((ch1 & 0xFC00) == 0xD800)) {
+ if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
- } else if ((ch2 & ~0x3FF) == 0xD800) {
+ } else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
#endif
@@ -1331,7 +1566,7 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1350,6 +1585,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 <= 3
+ /* 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);
+}
+
/*
*----------------------------------------------------------------------
@@ -1380,7 +1661,7 @@ TclUtfCasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1417,8 +1698,8 @@ TclUtfCasecmp(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToUpper(
+int
+Tcl_UniCharToUpper(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1431,13 +1712,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);
-}
/*
*----------------------------------------------------------------------
@@ -1456,7 +1730,7 @@ Tcl_UniCharToUpper(
*/
int
-TclUCS4ToLower(
+Tcl_UniCharToLower(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1470,13 +1744,6 @@ TclUCS4ToLower(
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
-
-Tcl_UniChar
-Tcl_UniCharToLower(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) TclUCS4ToLower(ch);
-}
/*
*----------------------------------------------------------------------
@@ -1494,8 +1761,8 @@ Tcl_UniCharToLower(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToTitle(
+int
+Tcl_UniCharToTitle(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1517,13 +1784,6 @@ UCS4ToTitle(
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
-
-Tcl_UniChar
-Tcl_UniCharToTitle(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) UCS4ToTitle(ch);
-}
/*
*----------------------------------------------------------------------
@@ -1656,11 +1916,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);
}
@@ -1684,11 +1942,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);
}
@@ -1712,7 +1968,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;
@@ -1724,7 +1979,6 @@ Tcl_UniCharIsControl(
}
return 0;
}
-#endif
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
@@ -1748,11 +2002,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);
}
@@ -1776,11 +2028,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);
}
@@ -1804,11 +2054,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);
}
@@ -1832,11 +2080,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);
}
@@ -1860,11 +2106,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);
}
@@ -1888,13 +2132,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
@@ -1903,10 +2142,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;
@@ -1935,11 +2172,9 @@ 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);
}
@@ -1963,11 +2198,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);
}
@@ -2365,7 +2598,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:
@@ -2378,30 +2611,17 @@ TclUniCharMatch(
*---------------------------------------------------------------------------
*/
+#if TCL_UTF_MAX <= 3
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;
+ /* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
+ return Tcl_UtfToUniChar(src, ucs4Ptr);
}
-#if TCL_UTF_MAX == 4
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
@@ -2418,54 +2638,6 @@ TclUniCharToUCS4(
#endif
/*
- *---------------------------------------------------------------------------
- *
- * TclUCS4ToUtf --
- *
- * Store the given Unicode character as a sequence of UTF-8 bytes in the
- * provided buffer. Might output 6 bytes, if the code point > 0xFFFF.
- *
- * Results:
- * The return values is the number of bytes in the buffer that were
- * consumed. If ch == -1, this function outputs 0 bytes (empty string),
- * since TclGetUCS4 returns -1 for out-of-range indices.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclUCS4ToUtf(
- int ch, /* Unicode character to be stored in the
- * buffer. */
- char *buf) /* Buffer in which the UTF-8 representation of
- * the Unicode character is stored. Buffer must be
- * large enough to hold the UTF-8 character(s)
- * (at most 6 bytes). */
-{
-#if TCL_UTF_MAX <= 4
- if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
- /* Spit out a 4-byte UTF-8 character or 2 x 3-byte UTF-8 characters, depending on Tcl
- * version and/or TCL_UTF_MAX build value */
- int len = Tcl_UniCharToUtf(0xD800 | ((ch - 0x10000) >> 10), buf);
- return len + Tcl_UniCharToUtf(0xDC00 | (ch & 0x7FF), buf + len);
- }
-#endif
- if ((ch & ~0x7FF) == 0xD800) {
- buf[2] = (char) ((ch | 0x80) & 0xBF);
- buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
- buf[0] = (char) ((ch >> 12) | 0xE0);
- return 3;
- }
- if (ch == -1) {
- return 0;
- }
- return Tcl_UniCharToUtf(ch, buf);
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index a9819d5..8a995e5 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
+#include "tclTomMath.h"
#include <math.h>
/*
@@ -107,12 +108,11 @@ 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 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 intrep, 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 */
};
/*
@@ -1403,9 +1407,9 @@ TclConvertElement(
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
- src = tclEmptyStringRep;
- length = 0;
- conversion = CONVERT_BRACE;
+ p[0] = '{';
+ p[1] = '}';
+ return 2;
}
/*
@@ -1623,6 +1627,7 @@ Tcl_Merge(
return result;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -1656,6 +1661,7 @@ Tcl_Backslash(
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1686,7 +1692,7 @@ TclTrimRight(
* rely on (trim[numTrim] == '\0'). */
{
const char *pp, *p = bytes + numBytes;
- Tcl_UniChar ch1 = 0;
+ int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
@@ -1700,12 +1706,11 @@ TclTrimRight(
do {
const char *q = trim;
int pInc = 0, bytesLeft = numTrim;
- Tcl_UniChar ch2 = 0;
pp = TclUtfPrev(p, bytes);
do {
pp += pInc;
- pInc = TclUtfToUniChar(pp, &ch1);
+ pInc = TclUtfToUCS4(pp, &ch1);
} while (pp + pInc < p);
/*
@@ -1713,7 +1718,7 @@ TclTrimRight(
*/
do {
- int qInc = TclUtfToUniChar(q, &ch2);
+ int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
@@ -1766,7 +1771,7 @@ TclTrimLeft(
* rely on (trim[numTrim] == '\0'). */
{
const char *p = bytes;
- Tcl_UniChar ch1 = 0;
+ int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
@@ -1778,8 +1783,7 @@ TclTrimLeft(
*/
do {
- Tcl_UniChar ch2 = 0;
- int pInc = TclUtfToUniChar(p, &ch1);
+ int pInc = TclUtfToUCS4(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
@@ -1788,7 +1792,7 @@ TclTrimLeft(
*/
do {
- int qInc = TclUtfToUniChar(q, &ch2);
+ int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
@@ -2013,7 +2017,7 @@ Tcl_ConcatObj(
if (TclListObjIsCanonical(objPtr)) {
continue;
}
- Tcl_GetStringFromObj(objPtr, &length);
+ TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
@@ -2022,7 +2026,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) {
@@ -2102,6 +2106,7 @@ Tcl_ConcatObj(
return resPtr;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -2120,6 +2125,7 @@ Tcl_ConcatObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_StringMatch
int
Tcl_StringMatch(
const char *str, /* String. */
@@ -2128,7 +2134,7 @@ Tcl_StringMatch(
{
return Tcl_StringCaseMatch(str, pattern, 0);
}
-
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
@@ -2202,7 +2208,7 @@ Tcl_StringCaseMatch(
} else {
TclUtfToUCS4(pattern, &ch2);
if (nocase) {
- ch2 = TclUCS4ToLower(ch2);
+ ch2 = Tcl_UniCharToLower(ch2);
}
}
@@ -2217,7 +2223,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;
@@ -2276,7 +2282,7 @@ Tcl_StringCaseMatch(
} else {
str += TclUtfToUCS4(str, &ch1);
if (nocase) {
- ch1 = TclUCS4ToLower(ch1);
+ ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
@@ -2290,7 +2296,7 @@ Tcl_StringCaseMatch(
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
if (nocase) {
- startChar = TclUCS4ToLower(startChar);
+ startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
@@ -2305,7 +2311,7 @@ Tcl_StringCaseMatch(
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
- endChar = TclUCS4ToLower(endChar);
+ endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
@@ -2354,7 +2360,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) {
@@ -2391,7 +2397,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;
@@ -2576,7 +2582,7 @@ TclStringMatchObj(
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
- if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) {
+ if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
udata = Tcl_GetUnicodeFromObj(strObj, &length);
@@ -2715,7 +2721,7 @@ TclDStringAppendObj(
Tcl_Obj *objPtr)
{
int length;
- char *bytes = Tcl_GetStringFromObj(objPtr, &length);
+ char *bytes = TclGetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
@@ -2953,7 +2959,6 @@ Tcl_DStringResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
- Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
}
@@ -2983,6 +2988,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) {
@@ -3006,7 +3019,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;
@@ -3016,7 +3029,7 @@ Tcl_DStringGetResult(
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
TclFreeIntRep(iPtr->objResultPtr);
- iPtr->objResultPtr->bytes = tclEmptyStringRep;
+ iPtr->objResultPtr->bytes = &tclEmptyString;
iPtr->objResultPtr->length = 0;
}
return;
@@ -3054,6 +3067,7 @@ Tcl_DStringGetResult(
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -3192,9 +3206,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. */
@@ -3274,13 +3286,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) {
@@ -3366,16 +3378,17 @@ Tcl_PrintDouble(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *
TclPrecTraceProc(
- ClientData clientData, /* Not used. */
+ ClientData 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));
/*
@@ -3399,7 +3412,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;
}
@@ -3415,13 +3428,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)*/
/*
*----------------------------------------------------------------------
@@ -3545,9 +3559,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";
@@ -3556,7 +3570,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;
@@ -3583,159 +3597,135 @@ TclFormatInt(
/*
*----------------------------------------------------------------------
*
- * TclGetIntForIndex --
- *
- * Provides an integer corresponding to the list index held in a Tcl
- * object. The string value 'objPtr' is expected have the format
- * integer([+-]integer)? or end([+-]integer)?.
- *
- * Value
- * TCL_OK
- *
- * The index is stored at the address given by by 'indexPtr'. If
- * 'objPtr' has the value "end", the value stored is 'endValue'.
- *
- * TCL_ERROR
+ * GetWideForIndex --
*
- * The value of 'objPtr' does not have one of the expected formats. If
- * 'interp' is non-NULL, an error message is left in the interpreter's
- * result object.
+ * 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.
*
- * Effect
+ * 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.
*
- * The object referenced by 'objPtr' is converted, as needed, to an
- * integer, wide integer, or end-based-index object.
+ * Side effects:
+ * The type of *objPtr may change.
*
*----------------------------------------------------------------------
*/
-int
-TclGetIntForIndex(
- Tcl_Interp *interp, /* Interpreter to use for error reporting. If
- * NULL, then no error message is left after
- * errors. */
- Tcl_Obj *objPtr, /* Points to an object containing either "end"
- * or an integer. */
- int endValue, /* The value to be stored at "indexPtr" if
- * "objPtr" holds "end". */
- int *indexPtr) /* Location filled in with an integer
- * representing an index. */
+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 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);
-
- /*
- * Leading whitespace is acceptable in an index.
- */
-
- while (length && TclIsSpaceProcM(*bytes)) {
- bytes++;
- length--;
- }
-
- 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;
+ int numType;
+ ClientData cd;
+ int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
+
+ if (code == TCL_OK) {
+ if (numType == TCL_NUMBER_INT) {
+ /* objPtr holds an integer in the signed wide range */
+ *widePtr = *(Tcl_WideInt *)cd;
+ return TCL_OK;
}
- if (TclIsSpaceProcM(opPtr[1])) {
- goto parseError;
+ 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;
}
- *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;
- } else {
- *indexPtr = first - second;
- }
- return TCL_OK;
- }
-
- /*
- * Report a parse error.
- */
-
- parseError:
- if (interp != NULL) {
- bytes = TclGetString(objPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be integer?[+-]integer? or"
- " end?[+-]integer?", bytes));
- if (!strncmp(bytes, "end-", 4)) {
- bytes += 4;
- }
- TclCheckBadOctal(interp, bytes);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
- return TCL_ERROR;
+ /* objPtr does not hold a number, check the end+/- format... */
+ return GetEndOffsetFromObj(interp, objPtr, endValue, widePtr);
}
/*
*----------------------------------------------------------------------
*
- * UpdateStringOfEndOffset --
+ * Tcl_GetIntForIndex --
*
- * Update the string rep of a Tcl object holding an "end-offset"
- * expression.
+ * This function returns an integer corresponding to the list index held
+ * in a Tcl object. The Tcl object's value is expected to be in the
+ * format integer([+-]integer)? or the format end([+-]integer)?.
*
* Results:
- * None.
+ * The return value is normally TCL_OK, which means that the index was
+ * successfully stored into the location referenced by "indexPtr". If the
+ * Tcl object referenced by "objPtr" has the value "end", the value
+ * stored is "endValue". If "objPtr"s values is not of one of the
+ * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL,
+ * an error message is left in the interpreter's result object.
*
* 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.
+ * The object referenced by "objPtr" might be converted to an integer,
+ * wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
-static void
-UpdateStringOfEndOffset(
- Tcl_Obj *objPtr)
+int
+Tcl_GetIntForIndex(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ Tcl_Obj *objPtr, /* Points to an object containing either "end"
+ * or an integer. */
+ int endValue, /* The value to be stored at "indexPtr" if
+ * "objPtr" holds "end". */
+ int *indexPtr) /* Location filled in with an integer
+ * representing an index. May be NULL.*/
{
- char buffer[TCL_INTEGER_SPACE + 5];
- int len = 3;
+ Tcl_WideInt wide;
- memcpy(buffer, "end", 4);
- if (objPtr->internalRep.longValue != 0) {
- buffer[len++] = '-';
- len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
+ if (GetWideForIndex(interp, objPtr, (size_t)(endValue + 1) - 1, &wide) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (indexPtr != NULL) {
+ if ((wide < 0) && (endValue > TCL_INDEX_END)) {
+ *indexPtr = -1;
+ } else if (wide > INT_MAX) {
+ *indexPtr = INT_MAX;
+ } else if (wide < INT_MIN) {
+ *indexPtr = INT_MIN;
+ } else {
+ *indexPtr = (int) wide;
+ }
}
- objPtr->bytes = (char *)ckalloc(len+1);
- memcpy(objPtr->bytes, buffer, len+1);
- objPtr->length = len;
+ return TCL_OK;
}
-
/*
*----------------------------------------------------------------------
*
* GetEndOffsetFromObj --
*
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
+ * Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
+ * convert it to an internal representation.
+ *
+ * The internal representation (wideValue) uses the following encoding:
+ *
+ * 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.
@@ -3748,119 +3738,240 @@ 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_ObjIntRep *irPtr;
+ Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
+ ClientData cd;
- /* TODO: Handle overflow cases sensibly */
- *indexPtr = endValue + (int)objPtr->internalRep.longValue;
- return TCL_OK;
-}
+ while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) {
+ Tcl_ObjIntRep ir;
+ int length;
+ const char *bytes = TclGetStringFromObj(objPtr, &length);
+ if (*bytes != 'e') {
+ int numType;
+ const char *opPtr;
+ int length, 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(TclGetString(objPtr), -1, NULL) > 1)
- /*
- * Check for a string rep of the right form.
- */
+ /* If it's possible, do the full list parse. */
+ && (TCL_OK == Tcl_ListObjLength(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, -1, &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 */
+ TclGetNumberFromObj(NULL, objPtr, &cd, &t1);
+ if (t1 == TCL_NUMBER_INT) {
+ w1 = (*(Tcl_WideInt *)cd);
+ }
+
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
+ -1, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* ... value concludes with second valid integer */
+
+ /* Save second integer as wide if possible */
+ TclGetNumberFromObj(NULL, objPtr, &cd, &t2);
+ if (t2 == TCL_NUMBER_INT) {
+ w2 = (*(Tcl_WideInt *)cd);
+ }
+ }
+ }
+ /* Clear invalid intreps left by TclParseNumber */
+ TclFreeIntRep(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) && (interp != NULL)) {
+ 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 if (interp == NULL) {
+ /*
+ * We use an interp to do bignum index calculations.
+ * If we don't get one, call all indices with bignums errors,
+ * and rely on callers to handle it.
+ */
+ goto parseError;
+ } 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:
+ Tcl_ExprObj(interp, objPtr, &sum);
+ TclGetNumberFromObj(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] == '-') {
- /* TODO: Review overflow concerns here! */
- offset = -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;
- badIndexFormat:
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ /* Parse for the "end-..." or "end+..." formats */
+
+ if ((bytes[3] != '-') && (bytes[3] != '+')) {
+ /* No operator where we need one */
+ goto parseError;
+ }
+ if (TclIsSpaceProc(bytes[4])) {
+ /* Space after + or - not permitted. */
+ goto parseError;
+ }
+
+ /* Parse the integer offset */
+ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
+ bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* Not a recognized integer format */
+ goto parseError;
+ }
+
+ /* Got an integer offset; pull it from where parser left it. */
+ TclGetNumberFromObj(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_StoreIntRep(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;
}
/*
@@ -3875,7 +3986,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
@@ -3884,9 +3995,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.
@@ -3926,47 +4037,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+postive 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_ObjIntRep *irPtr = TclFetchIntRep(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;
}
@@ -3994,10 +4090,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;
}
/*
@@ -4213,7 +4313,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) {
@@ -4256,7 +4357,7 @@ TclGetProcessGlobalValue(
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
- int epoch = pgvPtr->epoch;
+ unsigned int epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
@@ -4406,11 +4507,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;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 7b3db7e..72724a4 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -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,14 +60,12 @@ 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 VarHashGetValue(hPtr);
- } else {
+ if (!hPtr) {
return NULL;
}
+ return VarHashGetValue(hPtr);
}
#define VarHashFindVar(tablePtr, key) \
@@ -92,11 +90,10 @@ VarHashFirstVar(
{
Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr);
- if (hPtr) {
- return VarHashGetValue(hPtr);
- } else {
+ if (!hPtr) {
return NULL;
}
+ return VarHashGetValue(hPtr);
}
static inline Var *
@@ -105,11 +102,10 @@ VarHashNextVar(
{
Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr);
- if (hPtr) {
- return VarHashGetValue(hPtr);
- } else {
+ if (!hPtr) {
return NULL;
}
+ return VarHashGetValue(hPtr);
}
#define VarHashGetKey(varPtr) \
@@ -149,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. */
@@ -168,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);
@@ -191,8 +207,16 @@ 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 int ArrayDefaultCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static void DeleteArrayVar(Var *arrayPtr);
+static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj);
/*
* Functions defined in this file that may be exported in the future for use
@@ -205,14 +229,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.
@@ -231,30 +250,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 LocalSetIntRep(objPtr, index, namePtr) \
+ do { \
+ Tcl_ObjIntRep ir; \
+ Tcl_Obj *ptr = (namePtr); \
+ if (ptr) {Tcl_IncrRefCount(ptr);} \
+ ir.twoPtrValue.ptr1 = ptr; \
+ ir.twoPtrValue.ptr2 = INT2PTR(index); \
+ Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \
+ } while (0)
+
+#define LocalGetIntRep(objPtr, index, name) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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 ParsedSetIntRep(objPtr, arrayPtr, elem) \
+ do { \
+ Tcl_ObjIntRep 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_StoreIntRep((objPtr), &parsedVarNameType, &ir); \
+ } while (0)
+
+#define ParsedGetIntRep(objPtr, parsed, array, elem) \
+ do { \
+ const Tcl_ObjIntRep *irPtr; \
+ irPtr = TclFetchIntRep((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(
@@ -340,7 +381,8 @@ CleanupVar(
{
if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
&& !TclIsVarTraced(varPtr)
- && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) {
+ && (VarHashRefCount(varPtr) == (unsigned)
+ !TclIsVarDeadHash(varPtr))) {
if (VarHashRefCount(varPtr) == 0) {
ckfree(varPtr);
} else {
@@ -349,7 +391,8 @@ CleanupVar(
}
if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) &&
TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
- (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) {
+ (VarHashRefCount(arrayPtr) == (unsigned)
+ !TclIsVarDeadHash(arrayPtr))) {
if (VarHashRefCount(arrayPtr) == 0) {
ckfree(arrayPtr);
} else {
@@ -477,9 +520,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.
*
@@ -489,7 +531,7 @@ TclLookupVar(
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
- register Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an
+ Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an
* array. Otherwise, this is a full variable
* name that could include a parenthesized
* array element. */
@@ -561,24 +603,20 @@ TclObjLookupVarEx(
* is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
- register Var *varPtr; /* Points to the variable's in-frame Var
+ 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;
+
+ int localIndex;
+ Tcl_Obj *namePtr, *arrayPtr, *elem;
- if (typePtr == &localVarNameType) {
- int localIndex;
+ *arrayPtrPtr = NULL;
- localVarNameTypeHandling:
- localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2);
+ restart:
+ LocalGetIntRep(part1Ptr, localIndex, namePtr);
+ if (localIndex >= 0) {
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
@@ -586,8 +624,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))) {
@@ -599,12 +636,11 @@ TclObjLookupVarEx(
}
/*
- * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed
- * parts.
+ * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts.
*/
- if (typePtr == &tclParsedVarNameType) {
- if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
+ ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem);
+ if (parsed && arrayPtr) {
if (part2Ptr != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot specify
@@ -618,33 +654,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.
*/
- register 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,
@@ -655,49 +681,13 @@ TclObjLookupVarEx(
return NULL;
}
- /*
- * part1Ptr points to an array element; first copy the element
- * name to a new string part2.
- */
-
- part2 = part1 + i + 1;
- len2 = len1 - i - 2;
- len1 = i;
-
- newPart2 = ckalloc(len2 + 1);
- memcpy(newPart2, part2, (unsigned) len2);
- *(newPart2+len2) = '\0';
- part2 = newPart2;
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
-
- /*
- * Free the internal rep of the original part1Ptr, now renamed
- * objPtr, and set it to tclParsedVarNameType.
- */
+ arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
+ part2Ptr = Tcl_NewStringObj(part2 + 1,
+ len - (part2 - part1) - 2);
- objPtr = part1Ptr;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclParsedVarNameType;
+ ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr);
- /*
- * 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;
}
}
}
@@ -708,8 +698,6 @@ TclObjLookupVarEx(
* the cached types if possible.
*/
- TclFreeIntRep(part1Ptr);
-
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
@@ -718,9 +706,6 @@ TclObjLookupVarEx(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(part1Ptr), NULL);
}
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
return NULL;
}
@@ -732,28 +717,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) {
+ LocalSetIntRep(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 intrep
+ * 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 intrep(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])
+ */
+ LocalSetIntRep(part1Ptr, index, cachedNamePtr);
+
+ /* Then wipe it */
+ TclFreeIntRep(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.
+ */
+ LocalSetIntRep(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;
+ ParsedSetIntRep(part1Ptr, NULL, NULL);
}
donePart1:
@@ -769,9 +772,6 @@ TclObjLookupVarEx(
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
createPart1, createPart2, varPtr, -1);
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
}
return varPtr;
}
@@ -938,38 +938,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;
@@ -980,7 +983,7 @@ TclLookupSimpleVar(
int localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
- register Tcl_Obj *objPtr = *objPtrPtr;
+ Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
localNameStr = TclGetStringFromObj(objPtr, &localLen);
@@ -996,7 +999,7 @@ TclLookupSimpleVar(
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
- tablePtr = ckalloc(sizeof(TclVarHashTable));
+ tablePtr = (TclVarHashTable *)ckalloc(sizeof(TclVarHashTable));
TclInitVarHashTable(tablePtr, NULL);
varFramePtr->varTablePtr = tablePtr;
}
@@ -1075,8 +1078,6 @@ TclLookupArrayElement(
{
int isNew;
Var *varPtr;
- TclVarHashTable *tablePtr;
- Namespace *nsPtr;
/*
* We're dealing with an array element. Make sure the variable is an array
@@ -1109,16 +1110,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,
@@ -1174,6 +1166,7 @@ TclLookupArrayElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetVar
const char *
Tcl_GetVar(
@@ -1194,6 +1187,7 @@ Tcl_GetVar(
}
return TclGetString(resultPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1330,10 +1324,10 @@ Tcl_Obj *
Tcl_ObjGetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
- register Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
+ Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
- register Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
+ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and
@@ -1428,7 +1422,7 @@ Tcl_Obj *
TclPtrGetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
- register Var *varPtr, /* The variable to be read.*/
+ Var *varPtr, /* The variable to be read.*/
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
@@ -1466,6 +1460,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)) {
@@ -1508,11 +1524,10 @@ TclPtrGetVarIdx(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_SetObjCmd(
- ClientData dummy, /* Not used. */
- register Tcl_Interp *interp,/* Current interpreter. */
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
@@ -1563,6 +1578,7 @@ Tcl_SetObjCmd(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetVar
const char *
Tcl_SetVar(
@@ -1575,18 +1591,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 */
/*
*----------------------------------------------------------------------
@@ -1738,10 +1751,10 @@ Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
- register Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
+ Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
- register Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding
+ Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *newValuePtr, /* New value for variable. */
@@ -1828,6 +1841,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
@@ -1854,7 +1991,7 @@ Tcl_Obj *
TclPtrSetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
- register Var *varPtr, /* Reference to the variable to set. */
+ Var *varPtr, /* Reference to the variable to set. */
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
@@ -1940,44 +2077,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) {
/*
@@ -2205,7 +2311,7 @@ TclPtrIncrObjVarIdx(
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
- register Tcl_Obj *varValuePtr;
+ Tcl_Obj *varValuePtr;
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
@@ -2232,7 +2338,6 @@ TclPtrIncrObjVarIdx(
} else {
/* Unshared - can Incr in place */
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
-
/*
* This seems dumb to write the incremeted value into the var
* after we just adjusted the value in place, but the spec for
@@ -2268,6 +2373,7 @@ TclPtrIncrObjVarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
@@ -2296,6 +2402,7 @@ Tcl_UnsetVar(
Tcl_DecrRefCount(varNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2465,7 +2572,7 @@ int
TclPtrUnsetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
- register Var *varPtr, /* The variable to be unset. */
+ Var *varPtr, /* The variable to be unset. */
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
@@ -2598,7 +2705,7 @@ UnsetVarStruct(
int isNew;
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
- tracePtr = Tcl_GetHashValue(tPtr);
+ tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
varPtr->flags &= ~VAR_ALL_TRACES;
Tcl_DeleteHashEntry(tPtr);
if (dummyVar.flags & VAR_TRACED_UNSET) {
@@ -2625,7 +2732,7 @@ UnsetVarStruct(
if (TclIsVarTraced(&dummyVar)) {
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
if (tPtr) {
- tracePtr = Tcl_GetHashValue(tPtr);
+ tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
Tcl_DeleteHashEntry(tPtr);
}
}
@@ -2711,16 +2818,15 @@ UnsetVarStruct(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_UnsetObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- register int i, flags = TCL_LEAVE_ERR_MSG;
- register const char *name;
+ int i, flags = TCL_LEAVE_ERR_MSG;
+ const char *name;
if (objc == 1) {
/*
@@ -2779,16 +2885,15 @@ Tcl_UnsetObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_AppendObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Var *varPtr, *arrayPtr;
- register Tcl_Obj *varValuePtr = NULL;
+ Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler warning. */
int i;
@@ -2845,10 +2950,9 @@ Tcl_AppendObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_LappendObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2972,6 +3076,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(
+ ClientData 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(ClientData),
+ 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 (Tcl_ListObjLength(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(
+ ClientData 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;
+ }
+
+ Tcl_ListObjGetElements(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
@@ -2987,20 +3395,16 @@ Tcl_LappendObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayStartSearchCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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");
@@ -3019,24 +3423,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;
}
/*
@@ -3056,15 +3490,14 @@ ArrayStartSearchCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayAnyMoreCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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;
@@ -3135,10 +3568,9 @@ ArrayAnyMoreCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayNextElementCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3216,19 +3648,17 @@ ArrayNextElementCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayDoneSearchCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
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) {
@@ -3255,27 +3685,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;
}
@@ -3297,10 +3708,9 @@ ArrayDoneSearchCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayExistsCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3338,10 +3748,9 @@ ArrayExistsCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayGetCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3498,10 +3907,9 @@ ArrayGetCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3666,10 +4074,9 @@ TclFindArrayPtrElements(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArraySetCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3708,7 +4115,7 @@ ArraySetCmd(
*/
arrayElemObj = objv[2];
- if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
+ if (TclHasIntRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
@@ -3786,7 +4193,8 @@ ArraySetCmd(
if ((elemVarPtr == NULL) ||
(TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
- elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
+ elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG,
+ -1) == NULL)) {
result = TCL_ERROR;
break;
}
@@ -3820,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;
}
@@ -3843,10 +4249,9 @@ ArraySetCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArraySizeCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3903,10 +4308,9 @@ ArraySizeCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayStatsCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3958,10 +4362,9 @@ ArrayStatsCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ArrayUnsetCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -4095,15 +4498,16 @@ ArrayUnsetCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
Tcl_Command
TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
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},
@@ -4128,7 +4532,7 @@ TclInitArrayCmd(
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
- * message is left in iPtr->result.
+ * message is left in interp.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
@@ -4222,7 +4626,7 @@ ObjMakeUpvar(
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
- * message is left in iPtr->result.
+ * message is left in interp.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
@@ -4413,6 +4817,7 @@ TclPtrObjMakeUpvarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UpVar
int
Tcl_UpVar(
@@ -4446,6 +4851,7 @@ Tcl_UpVar(
Tcl_DecrRefCount(localNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -4529,7 +4935,7 @@ Tcl_GetVariableFullName(
* variable's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
- register Var *varPtr = (Var *) variable;
+ Var *varPtr = (Var *) variable;
Tcl_Obj *namePtr;
Namespace *nsPtr;
@@ -4583,15 +4989,15 @@ Tcl_GetVariableFullName(
int
Tcl_GlobalObjCmd(
- 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;
- register Tcl_Obj *objPtr, *tailPtr;
+ Tcl_Obj *objPtr, *tailPtr;
const char *varName;
- register const char *tail;
+ const char *tail;
int result, i;
/*
@@ -4687,7 +5093,7 @@ Tcl_GlobalObjCmd(
int
Tcl_VariableObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4818,10 +5224,9 @@ Tcl_VariableObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_UpvarObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4901,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
@@ -4980,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.
- *
*----------------------------------------------------------------------
*/
@@ -4999,65 +5331,43 @@ ParseSearchId(
* name. */
{
Interp *iPtr = (Interp *) interp;
- register const char *string;
- register 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;
}
@@ -5081,7 +5391,7 @@ ParseSearchId(
static void
DeleteSearches(
Interp *iPtr,
- register Var *arrayVarPtr) /* Variable whose searches are to be
+ Var *arrayVarPtr) /* Variable whose searches are to be
* deleted. */
{
ArraySearch *searchPtr, *nextPtr;
@@ -5089,9 +5399,10 @@ DeleteSearches(
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
- for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
+ for (searchPtr = (ArraySearch *)Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
@@ -5158,7 +5469,7 @@ TclDeleteNamespaceVars(
if (TclIsVarTraced(varPtr)) {
Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
- VarTrace *tracePtr = Tcl_GetHashValue(tPtr);
+ VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
ActiveVarTrace *activePtr;
while (tracePtr) {
@@ -5222,7 +5533,7 @@ TclDeleteVars(
{
Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
- register Var *varPtr;
+ Var *varPtr;
int flags;
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
@@ -5274,7 +5585,7 @@ TclDeleteCompiledLocalVars(
CallFrame *framePtr) /* Procedure call frame containing compiler-
* assigned local variables to delete. */
{
- register Var *varPtr;
+ Var *varPtr;
int numLocals, i;
Tcl_Obj **namePtrPtr;
@@ -5323,7 +5634,7 @@ DeleteArray(
{
Tcl_HashSearch search;
Tcl_HashEntry *tPtr;
- register Var *elPtr;
+ Var *elPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
VarTrace *tracePtr;
@@ -5355,7 +5666,7 @@ DeleteArray(
elNamePtr, flags,/* leaveErrMsg */ 0, index);
}
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
- tracePtr = Tcl_GetHashValue(tPtr);
+ tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
@@ -5383,8 +5694,7 @@ DeleteArray(
TclClearVarNamespaceVar(elPtr);
}
- VarHashDeleteTable(varPtr->value.tablePtr);
- ckfree(varPtr->value.tablePtr);
+ DeleteArrayVar(varPtr);
}
/*
@@ -5462,28 +5772,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:
@@ -5496,12 +5784,15 @@ static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+
+ LocalGetIntRep(objPtr, index, namePtr);
+ index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5509,17 +5800,14 @@ DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ int index;
+ Tcl_Obj *namePtr;
+ LocalGetIntRep(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;
+ LocalSetIntRep(dupPtr, index, namePtr);
}
/*
@@ -5535,14 +5823,16 @@ static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
- register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- register char *elem = objPtr->internalRep.twoPtrValue.ptr2;
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
+ ParsedGetIntRep(objPtr, parsed, arrayPtr, elem);
+
+ parsed++; /* Silence compiler. */
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
- ckfree(elem);
+ TclDecrRefCount(elem);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5550,58 +5840,13 @@ DupParsedVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- register char *elem = srcPtr->internalRep.twoPtrValue.ptr2;
- char *elemCopy;
- unsigned elemLen;
-
- if (arrayPtr != NULL) {
- Tcl_IncrRefCount(arrayPtr);
- elemLen = strlen(elem);
- elemCopy = ckalloc(elemLen + 1);
- memcpy(elemCopy, elem, elemLen);
- *(elemCopy + elemLen) = '\0';
- elem = elemCopy;
- }
-
- dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr;
- dupPtr->internalRep.twoPtrValue.ptr2 = elem;
- dupPtr->typePtr = &tclParsedVarNameType;
-}
-
-static void
-UpdateParsedVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- char *part2 = objPtr->internalRep.twoPtrValue.ptr2;
- const char *part1;
- char *p;
- int len1, len2, totalLen;
-
- if (arrayPtr == NULL) {
- /*
- * This is a parsed scalar name: what is it doing here?
- */
-
- Tcl_Panic("scalar parsedVarName without a string rep");
- }
-
- part1 = TclGetStringFromObj(arrayPtr, &len1);
- len2 = strlen(part2);
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
- totalLen = len1 + len2 + 2;
- p = ckalloc(totalLen + 1);
- objPtr->bytes = p;
- objPtr->length = totalLen;
+ ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem);
- memcpy(p, part1, (unsigned) len1);
- p += len1;
- *p++ = '(';
- memcpy(p, part2, (unsigned) len2);
- p += len2;
- *p++ = ')';
- *p = '\0';
+ parsed++; /* Silence compiler. */
+ ParsedSetIntRep(dupPtr, arrayPtr, elem);
}
/*
@@ -5684,7 +5929,7 @@ ObjFindNamespaceVar(
Namespace *nsPtr[2], *cxtNsPtr;
const char *simpleName;
Var *varPtr;
- register int search;
+ int search;
int result;
Tcl_Var var;
Tcl_Obj *simpleNamePtr;
@@ -5792,7 +6037,7 @@ ObjFindNamespaceVar(
int
TclInfoVarsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -5930,7 +6175,7 @@ TclInfoVarsCmd(
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search);
+ varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search);
while (varPtr) {
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
@@ -5983,7 +6228,7 @@ TclInfoVarsCmd(
int
TclInfoGlobalsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6076,7 +6321,7 @@ TclInfoGlobalsCmd(
int
TclInfoLocalsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6226,25 +6471,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);
@@ -6266,14 +6536,14 @@ 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 = keyPtr;
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr;
Var *varPtr;
- varPtr = ckalloc(sizeof(VarInHash));
+ varPtr = (Var *)ckalloc(sizeof(VarInHash));
varPtr->flags = VAR_IN_HASHTABLE;
varPtr->value.objPtr = NULL;
VarHashRefCount(varPtr) = 1;
@@ -6309,17 +6579,17 @@ CompareVarKeys(
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 = hPtr->key.objPtr;
- register const char *p1, *p2;
- register int l1, l2;
+ const char *p1, *p2;
+ int l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
-
- if (objPtr1 == objPtr2) return 1;
- */
+ *
+ * if (objPtr1 == objPtr2) return 1;
+ */
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a
@@ -6338,6 +6608,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(ClientData),
+ 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 options { 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 (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..695c814
--- /dev/null
+++ b/generic/tclZipfs.c
@@ -0,0 +1,5027 @@
+/*
+ * tclZipfs.c --
+ *
+ * Implementation of the ZIP filesystem used in TIP 430
+ * Adapted from the implentation for AndroWish.
+ *
+ * Copyright (c) 2016-2017 Sean Woods <yoda@etoyoc.com>
+ * Copyright (c) 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
+#define crc32tab crc_table[0]
+#ifndef TBLS
+#define TBLS 1
+#endif
+
+#ifdef HAVE_ZLIB
+#include "zlib.h"
+#include "crypt.h"
+#include "zutil.h"
+#include "crc32.h"
+
+#ifdef CFG_RUNTIME_DLLFILE
+
+/*
+** 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"
+
+#else /* !CFG_RUNTIME_DLLFILE */
+
+/*
+** We are compiling from the /compat folder of tclconfig
+** Pre TIP430 style zipfs prefix
+** //zipfs:/ doesn't work straight out of the box on either windows or Unix
+** without other changes made to tip 430
+*/
+
+#define ZIPFS_VOLUME "zipfs:/"
+#define ZIPFS_VOLUME_LEN 7
+#define ZIPFS_APP_MOUNT "zipfs:/app"
+#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl"
+
+#endif /* CFG_RUNTIME_DLLFILE */
+
+/*
+ * 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)
+
+/*
+ * 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_POSIX_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
+ "%s: %s", errstr, Tcl_PosixError(interp))); \
+ } \
+ } while (0)
+
+/*
+ * Macros to read and write 16 and 32 bit integers from/to ZIP archives.
+ */
+
+#define ZipReadInt(p) \
+ ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24))
+#define ZipReadShort(p) \
+ ((p)[0] | ((p)[1] << 8))
+
+#define ZipWriteInt(p, v) \
+ do { \
+ (p)[0] = (v) & 0xff; \
+ (p)[1] = ((v) >> 8) & 0xff; \
+ (p)[2] = ((v) >> 16) & 0xff; \
+ (p)[3] = ((v) >> 24) & 0xff; \
+ } while (0)
+#define ZipWriteShort(p, v) \
+ do { \
+ (p)[0] = (v) & 0xff; \
+ (p)[1] = ((v) >> 8) & 0xff; \
+ } while (0)
+
+/*
+ * 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 */
+
+/*
+ * 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.
+ */
+
+typedef struct ZipEntry {
+ char *name; /* The full pathname of the virtual file */
+ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */
+ Tcl_WideInt 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 */
+ 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, 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 inline int DescribeMounted(Tcl_Interp *interp,
+ const char *mountPoint);
+static inline int ListMountPoints(Tcl_Interp *interp);
+static int ZipfsAppHookFindTclInit(const char *archive);
+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 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 void ZipfsExitHandler(ClientData clientData);
+static void ZipfsSetup(void);
+static int ZipChannelClose(void *instanceData,
+ Tcl_Interp *interp, int flags);
+static Tcl_DriverGetHandleProc ZipChannelGetFile;
+static int ZipChannelRead(void *instanceData, char *buf,
+ int toRead, int *errloc);
+#ifndef TCL_NO_DEPRECATED
+static int ZipChannelSeek(void *instanceData, long offset,
+ int mode, int *errloc);
+#endif
+static Tcl_WideInt ZipChannelWideSeek(void *instanceData, Tcl_WideInt 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 */
+#ifndef TCL_NO_DEPRECATED
+ 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)
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 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 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 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 int
+CountSlashes(
+ const char *string)
+{
+ int count = 0;
+ const char *p = string;
+
+ while (*p != '\0') {
+ if (*p == '/') {
+ count++;
+ }
+ p++;
+ }
+ return count;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 ZipEntry *
+ZipFSLookup(
+ char *filename)
+{
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z = NULL;
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
+ if (hPtr) {
+ z = (ZipEntry *)Tcl_GetHashValue(hPtr);
+ }
+ return z;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookupMount --
+ *
+ * This function returns an indication if the given file name corresponds
+ * to a mounted ZIP archive file.
+ *
+ * Results:
+ * Returns true, if the given file name is a mounted ZIP archive file.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+#ifdef NEVER_USED
+static int
+ZipFSLookupMount(
+ char *filename)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = Tcl_GetHashValue(hPtr);
+
+ if (strcmp(zf->mountPoint, filename) == 0) {
+ return 1;
+ }
+ }
+ return 0;
+}
+#endif /* NEVER_USED */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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;
+ }
+
+#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.
+ *
+ * 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;
+ unsigned char *p, *q;
+
+ p = zf->data + zf->length - ZIP_CENTRAL_END_LEN;
+ while (p >= zf->data) {
+ if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) {
+ if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) {
+ break;
+ }
+ p -= ZIP_SIG_LEN;
+ } else {
+ --p;
+ }
+ }
+ if (p < zf->data) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "wrong end signature");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL);
+ }
+ goto error;
+ }
+ zf->numFiles = ZipReadShort(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");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL);
+ }
+ goto error;
+ }
+ q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS);
+ p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS);
+ if ((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");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL);
+ }
+ goto error;
+ }
+ zf->baseOffset = zf->passOffset = p - q;
+ zf->directoryOffset = p - zf->data;
+ q = p;
+ for (i = 0; i < zf->numFiles; i++) {
+ int pathlen, comlen, extra;
+
+ if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) {
+ ZIPFS_ERROR(interp, "wrong header length");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL);
+ }
+ goto error;
+ }
+ if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) {
+ ZIPFS_ERROR(interp, "wrong header signature");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL);
+ }
+ goto error;
+ }
+ pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS);
+ comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ q = zf->data + zf->baseOffset;
+ if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) {
+ i = q[-5];
+ if (q - 5 - i > zf->data) {
+ zf->passBuf[0] = i;
+ memcpy(zf->passBuf + 1, q - 5 - i, 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;
+ zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0);
+ if (!zf->chan) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) {
+ 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");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
+ }
+ 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_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ 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;
+ } else {
+#ifdef _WIN32
+ int readSuccessful;
+# ifdef _WIN64
+ i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length);
+ readSuccessful = (i != 0);
+# else /* !_WIN64 */
+ zf->length = GetFileSize((HANDLE) handle, 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");
+ goto error;
+ }
+ zf->mountHandle = CreateFileMappingW((HANDLE) handle, 0, PAGE_READONLY,
+ 0, zf->length, 0);
+ if (zf->mountHandle == INVALID_HANDLE_VALUE) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ goto 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");
+ goto error;
+ }
+#else /* !_WIN32 */
+ zf->length = lseek(PTR2INT(handle), 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) {
+ ZIPFS_POSIX_ERROR(interp, "invalid file size");
+ goto error;
+ }
+ lseek(PTR2INT(handle), 0, SEEK_SET);
+ zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ,
+ MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0);
+ if (zf->data == MAP_FAILED) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ goto error;
+ }
+#endif /* _WIN32 */
+ }
+ return ZipFSFindTOC(interp, needZip, zf);
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSRootNode --
+ *
+ * This function generates the root node for a ZIPFS filesystem.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * ...
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCatalogFilesystem(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ ZipFile *zf0,
+ 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 *zf;
+ 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 ((pwlen > 255) || strchr(passwd, 0xff)) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
+ }
+ 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) {
+ zf = (ZipFile *)Tcl_GetHashValue(hPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s is already mounted on %s", zf->name, mountPoint));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL);
+ }
+ Unlock();
+ ZipFSCloseArchive(interp, zf0);
+ return TCL_ERROR;
+ }
+ zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
+ if (!zf) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ Unlock();
+ ZipFSCloseArchive(interp, zf0);
+ return TCL_ERROR;
+ }
+ Unlock();
+
+ *zf = *zf0;
+ zf->mountPoint = (char *)Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+ Tcl_CreateExitHandler(ZipfsExitHandler, zf);
+ zf->mountPointLen = strlen(zf->mountPoint);
+ zf->nameLength = strlen(zipname);
+ zf->name = (char *)ckalloc(zf->nameLength + 1);
+ memcpy(zf->name, zipname, zf->nameLength + 1);
+ zf->entries = NULL;
+ zf->topEnts = NULL;
+ zf->numOpen = 0;
+ 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 = (ZipEntry *)ckalloc(sizeof(ZipEntry));
+ Tcl_SetHashValue(hPtr, z);
+
+ z->tnext = NULL;
+ z->depth = CountSlashes(mountPoint);
+ z->zipFilePtr = zf;
+ z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
+ z->isEncrypted = 0;
+ z->offset = zf->baseOffset;
+ z->crc32 = 0;
+ z->timestamp = 0;
+ z->numBytes = z->numCompressedBytes = 0;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->data = NULL;
+ 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++) {
+ int extra, isdir = 0, dosTime, dosDate, nbcompr;
+ size_t offs, pathlen, comlen;
+ unsigned char *lq, *gq = NULL;
+ char *fullpath, *path;
+
+ pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS);
+ comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen);
+ path = Tcl_DStringValue(&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(q + ZIP_CENTRAL_LOCALHDR_OFFS);
+ if ((lq < zf->data) || (lq > zf->data + zf->length)) {
+ goto nextent;
+ }
+ nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS);
+ if (!isdir && (nbcompr == 0)
+ && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0)
+ && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) {
+ gq = q;
+ nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS);
+ }
+ offs = (lq - zf->data)
+ + ZIP_LOCAL_HEADER_LEN
+ + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS)
+ + ZipReadShort(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);
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2));
+ if (hPtr) {
+ /* 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 = (ZipEntry *)ckalloc(sizeof(ZipEntry));
+ z->name = NULL;
+ z->tnext = NULL;
+ z->depth = CountSlashes(fullpath);
+ z->zipFilePtr = zf;
+ z->isDirectory = isdir;
+ z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1)
+ && (nbcompr > 12);
+ z->offset = offs;
+ if (gq) {
+ z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS);
+ dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS);
+ dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS);
+ } else {
+ z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS);
+ dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS);
+ dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS);
+ }
+ z->numCompressedBytes = nbcompr;
+ z->data = NULL;
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
+ if (!isNew) {
+ /* should not happen but skip it anyway */
+ ckfree(z);
+ } else {
+ 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;
+ }
+ if (!z->isDirectory && (z->depth > 1)) {
+ char *dir, *end;
+ ZipEntry *zd;
+
+ Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, z->name, -1);
+ dir = Tcl_DStringValue(&ds);
+ for (end = strrchr(dir, '/'); end && (end != dir);
+ end = strrchr(dir, '/')) {
+ Tcl_DStringSetLength(&ds, end - dir);
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
+ if (!isNew) {
+ break;
+ }
+ zd = (ZipEntry *)ckalloc(sizeof(ZipEntry));
+ zd->name = NULL;
+ zd->tnext = NULL;
+ zd->depth = CountSlashes(dir);
+ zd->zipFilePtr = zf;
+ zd->isDirectory = 1;
+ zd->isEncrypted = 0;
+ zd->offset = z->offset;
+ zd->crc32 = 0;
+ zd->timestamp = z->timestamp;
+ zd->numBytes = zd->numCompressedBytes = 0;
+ zd->compressMethod = ZIP_COMPMETH_STORED;
+ zd->data = NULL;
+ 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 */
+
+ 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.initialized = 1;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ListMountPoints --
+ *
+ * This procedure lists the mount points and what's mounted there, or
+ * reports whether there are any mounts (if there's no interpreter). The
+ * read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no
+ * interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+ListMountPoints(
+ Tcl_Interp *interp)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ ZipFile *zf;
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ if (!interp) {
+ return TCL_OK;
+ }
+ zf = (ZipFile *)Tcl_GetHashValue(hPtr);
+ Tcl_AppendElement(interp, zf->mountPoint);
+ Tcl_AppendElement(interp, zf->name);
+ }
+ return (interp ? TCL_OK : TCL_BREAK);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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)
+{
+ Tcl_HashEntry *hPtr;
+ ZipFile *zf;
+
+ if (interp) {
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ if (hPtr) {
+ zf = (ZipFile *)Tcl_GetHashValue(hPtr);
+ 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. */
+ 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) {
+ if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
+ zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
+ if (!zf) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ 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) {
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ ckfree(zf);
+ 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 = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
+ if (!zf) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ return TCL_ERROR;
+ }
+ zf->isMemBuffer = 1;
+ zf->length = datalen;
+ if (copy) {
+ zf->data = (unsigned char *)attemptckalloc(datalen);
+ if (!zf->data) {
+ if (interp) {
+ Tcl_AppendResult(interp, "out of memory", (char *) NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ return TCL_ERROR;
+ }
+ memcpy(zf->data, data, datalen);
+ zf->ptrToFree = zf->data;
+ } else {
+ zf->data = data;
+ zf->ptrToFree = NULL;
+ }
+ zf->passBuf[0] = 0; /* stop valgrind cries */
+ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
+ "Memory Buffer");
+ ckfree(zf);
+ 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");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+ for (z = zf->entries; z; z = znext) {
+ znext = z->next;
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
+ if (hPtr) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ if (z->data) {
+ ckfree(z->data);
+ }
+ ckfree(z);
+ }
+ ZipFSCloseArchive(interp, zf);
+ Tcl_DeleteExitHandler(ZipfsExitHandler, 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. */
+{
+
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?mountpoint? ?zipfile? ?password?");
+ return TCL_ERROR;
+ }
+
+ return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL,
+ (objc > 2) ? Tcl_GetString(objv[2]) : NULL,
+ (objc > 3) ? Tcl_GetString(objv[3]) : NULL);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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;
+ char *pw, passBuf[264];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "password");
+ return TCL_ERROR;
+ }
+ pw = Tcl_GetString(objv[1]);
+ len = strlen(pw);
+ if (len == 0) {
+ return TCL_OK;
+ }
+ if ((len > 255) || strchr(pw, 0xff)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1));
+ return TCL_ERROR;
+ }
+ while (len > 0) {
+ int ch = pw[len - 1];
+
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ i++;
+ len--;
+ }
+ 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';
+ Tcl_AppendResult(interp, passBuf, (char *) NULL);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipAddFile --
+ *
+ * This procedure is used by ZipFSMkZipOrImgCmd() 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.
+ *
+ * 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. */
+ const char *path,
+ const char *name,
+ Tcl_Channel out,
+ const char *passwd, /* Password for encoding the file, or NULL if
+ * the file is to be unprotected. */
+ char *buf,
+ int bufsize,
+ Tcl_HashTable *fileHash)
+{
+ Tcl_Channel in;
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z;
+ z_stream stream;
+ const char *zpath;
+ int crc, flush, zpathlen;
+ size_t nbyte, nbytecompr, len, olen, align = 0;
+ Tcl_WideInt pos[3];
+ 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.
+ */
+
+ zpath = name;
+ while (zpath && zpath[0] == '/') {
+ zpath++;
+ }
+ if (!zpath || (zpath[0] == '\0')) {
+ return TCL_OK;
+ }
+
+ zpathlen = strlen(zpath);
+ if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "path too long for \"%s\"", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL);
+ return TCL_ERROR;
+ }
+ in = Tcl_OpenFileChannel(interp, path, "rb", 0);
+ if (!in) {
+#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_Obj *pathObj = Tcl_NewStringObj(path, -1);
+ Tcl_StatBuf statBuf;
+
+ Tcl_IncrRefCount(pathObj);
+ if (Tcl_FSStat(pathObj, &statBuf) != -1) {
+ mtime = statBuf.st_mtime;
+ }
+ Tcl_DecrRefCount(pathObj);
+ }
+ Tcl_ResetResult(interp);
+ crc = 0;
+ nbyte = nbytecompr = 0;
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ if (nbyte == 0 && errno == EISDIR) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
+ path, 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",
+ path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ pos[0] = Tcl_Tell(out);
+ memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
+ memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen);
+ len = zpathlen + ZIP_LOCAL_HEADER_LEN;
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ wrerr:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error on %s: %s", path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ if ((len + pos[0]) & 3) {
+ unsigned char abuf[8];
+
+ /*
+ * Align payload to next 4-byte boundary using a dummy extra entry
+ * similar to the zipalign tool from Android's SDK.
+ */
+
+ align = 4 + ((len + pos[0]) & 3);
+ ZipWriteShort(abuf, 0xffff);
+ ZipWriteShort(abuf + 2, align - 4);
+ ZipWriteInt(abuf + 4, 0x03020100);
+ if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) {
+ goto wrerr;
+ }
+ }
+ if (passwd) {
+ int i, ch, tmp;
+ unsigned char kvbuf[24];
+ Tcl_Obj *ret;
+
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < 12 - 2; i++) {
+ double r;
+
+ if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) {
+ Tcl_Obj *eiPtr = Tcl_ObjPrintf(
+ "\n (evaluating PRNG step %d for password encoding)",
+ i);
+
+ Tcl_AppendObjToErrorInfo(interp, eiPtr);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ ret = Tcl_GetObjResult(interp);
+ if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) {
+ Tcl_Obj *eiPtr = Tcl_ObjPrintf(
+ "\n (evaluating PRNG step %d for password encoding)",
+ i);
+
+ Tcl_AppendObjToErrorInfo(interp, eiPtr);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ ch = (int) (r * 256);
+ 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) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error on %s: %s", path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ memcpy(keys0, keys, sizeof(keys0));
+ nbytecompr += 12;
+ }
+ Tcl_Flush(out);
+ pos[2] = Tcl_Tell(out);
+ 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\"", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ do {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "read error on %s: %s", path, Tcl_PosixError(interp)));
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ 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", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL);
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ 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)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ nbytecompr += olen;
+ } while (stream.avail_out == 0);
+ } while (flush != Z_FINISH);
+ deflateEnd(&stream);
+ Tcl_Flush(out);
+ pos[1] = 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, pos[2], SEEK_SET) != pos[2]) {
+ seekErr:
+ Tcl_Close(interp, in);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ nbytecompr = (passwd ? 12 : 0);
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "read error on \"%s\": %s",
+ path, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ } 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) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ nbytecompr += len;
+ }
+ compMeth = ZIP_COMPMETH_STORED;
+ Tcl_Flush(out);
+ pos[1] = Tcl_Tell(out);
+ Tcl_TruncateChannel(out, pos[1]);
+ }
+ Tcl_Close(interp, in);
+
+ hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "non-unique path name \"%s\"", path));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL);
+ return TCL_ERROR;
+ }
+
+ z = (ZipEntry *)ckalloc(sizeof(ZipEntry));
+ Tcl_SetHashValue(hPtr, z);
+ z->name = NULL;
+ z->tnext = NULL;
+ z->depth = 0;
+ z->zipFilePtr = NULL;
+ z->isDirectory = 0;
+ z->isEncrypted = (passwd ? 1 : 0);
+ z->offset = pos[0];
+ z->crc32 = crc;
+ z->timestamp = mtime;
+ z->numBytes = nbyte;
+ z->numCompressedBytes = nbytecompr;
+ z->compressMethod = compMeth;
+ z->data = NULL;
+ z->name = (char *)Tcl_GetHashKey(fileHash, hPtr);
+ z->next = NULL;
+
+ /*
+ * Write final local header information.
+ */
+ ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
+ ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod);
+ ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp));
+ ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp));
+ ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes);
+ ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen);
+ ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
+ if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) {
+ 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, pos[1], SEEK_SET) != pos[1]) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipOrImgObjCmd --
+ *
+ * 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.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A new ZIP archive file or image file is written.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipOrImgObjCmd(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int isImg,
+ int isList,
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Channel out;
+ int pwlen = 0, count, ret = TCL_ERROR, lobjc;
+ size_t len, slen = 0, i = 0;
+ Tcl_WideInt pos[3];
+ Tcl_Obj **lobjv, *list = NULL;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_HashTable fileHash;
+ char *strip = NULL, *pw = NULL, passBuf[264], buf[4096];
+
+ /*
+ * Caller has verified that the number of arguments is correct.
+ */
+
+ passBuf[0] = 0;
+ if (objc > (isList ? 3 : 4)) {
+ pw = Tcl_GetString(objv[isList ? 3 : 4]);
+ pwlen = strlen(pw);
+ if ((pwlen > 255) || strchr(pw, 0xff)) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("illegal password", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
+ return TCL_ERROR;
+ }
+ }
+ if (isList) {
+ list = objv[2];
+ Tcl_IncrRefCount(list);
+ } else {
+ Tcl_Obj *cmd[3];
+
+ cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1);
+ cmd[2] = objv[2];
+ cmd[0] = Tcl_NewListObj(2, cmd + 1);
+ Tcl_IncrRefCount(cmd[0]);
+ if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) {
+ Tcl_DecrRefCount(cmd[0]);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(cmd[0]);
+ list = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(list);
+ }
+ if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ if (isList && (lobjc % 2)) {
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("need even number of elements", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL);
+ return TCL_ERROR;
+ }
+ if (lobjc == 0) {
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL);
+ return TCL_ERROR;
+ }
+ out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755);
+ if (out == NULL) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ if (pwlen <= 0) {
+ pw = NULL;
+ pwlen = 0;
+ }
+ if (isImg) {
+ ZipFile *zf, zf0;
+ int isMounted = 0;
+ const char *imgName;
+
+ if (isList) {
+ imgName = (objc > 4) ? Tcl_GetString(objv[4]) :
+ Tcl_GetNameOfExecutable();
+ } else {
+ imgName = (objc > 5) ? Tcl_GetString(objv[5]) :
+ 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;
+ }
+ if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
+ 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 {
+ size_t k;
+ int m, n;
+ Tcl_Channel in;
+ const char *errMsg = "seek error";
+
+ /*
+ * Fall back to read it as plain file which hopefully is a static
+ * tclsh or wish binary with proper zipfs infrastructure built in.
+ */
+
+ Tcl_ResetResult(interp);
+ in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644);
+ if (!in) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ i = Tcl_Seek(in, 0, SEEK_END);
+ if (i == ERROR_LENGTH) {
+ cperr:
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s: %s", errMsg, Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ Tcl_Seek(in, 0, SEEK_SET);
+ 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 cperr;
+ } else if (n == 0) {
+ break;
+ }
+ m = Tcl_Write(out, buf, n);
+ if (m != n) {
+ errMsg = "write error";
+ goto cperr;
+ }
+ }
+ Tcl_Close(interp, in);
+ }
+ 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);
+ }
+ Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
+ pos[0] = Tcl_Tell(out);
+ if (!isList && (objc > 3)) {
+ strip = Tcl_GetString(objv[3]);
+ slen = strlen(strip);
+ }
+ for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
+ const char *path, *name;
+
+ path = Tcl_GetString(lobjv[i]);
+ if (isList) {
+ name = Tcl_GetString(lobjv[i + 1]);
+ } else {
+ name = path;
+ if (slen > 0) {
+ len = strlen(name);
+ if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
+ continue;
+ }
+ name += slen;
+ }
+ }
+ while (name[0] == '/') {
+ ++name;
+ }
+ if (name[0] == '\0') {
+ continue;
+ }
+ if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf),
+ &fileHash) != TCL_OK) {
+ goto done;
+ }
+ }
+ pos[1] = Tcl_Tell(out);
+ count = 0;
+ for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
+ const char *path, *name;
+
+ path = Tcl_GetString(lobjv[i]);
+ if (isList) {
+ name = Tcl_GetString(lobjv[i + 1]);
+ } else {
+ name = path;
+ if (slen > 0) {
+ len = strlen(name);
+ if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
+ continue;
+ }
+ name += slen;
+ }
+ }
+ while (name[0] == '/') {
+ ++name;
+ }
+ if (name[0] == '\0') {
+ continue;
+ }
+ hPtr = Tcl_FindHashEntry(&fileHash, name);
+ if (!hPtr) {
+ continue;
+ }
+ z = (ZipEntry *)Tcl_GetHashValue(hPtr);
+ len = strlen(z->name);
+ ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG);
+ ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod);
+ ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp));
+ ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp));
+ ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes);
+ ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len);
+ ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0);
+ ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0);
+ ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]);
+ if ((Tcl_Write(out, buf,
+ ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN)
+ || ((size_t) Tcl_Write(out, z->name, len) != len)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ goto done;
+ }
+ count++;
+ }
+ Tcl_Flush(out);
+ pos[2] = Tcl_Tell(out);
+ ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG);
+ ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0);
+ ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count);
+ ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count);
+ ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]);
+ ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]);
+ ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0);
+ 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkzip] and [zipfs
+ * lmkzip] commands. See description of ZipFSMkZipOrImgCmd().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description of ZipFSMkZipOrImgCmd().
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
+ return TCL_ERROR;
+ }
+ return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv);
+}
+
+static int
+ZipFSLMkZipObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
+ return TCL_ERROR;
+ }
+ return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkimg] and [zipfs
+ * lmkimg] commands. See description of ZipFSMkZipOrImgCmd().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description of ZipFSMkZipOrImgCmd().
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkImgObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc < 3 || objc > 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "outfile indir ?strip? ?password? ?infile?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
+ return TCL_ERROR;
+ }
+ return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv);
+}
+
+static int
+ZipFSLMkImgObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "operation not permitted in a safe interpreter", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
+ return TCL_ERROR;
+ }
+ return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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);
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ int n;
+ char *what = Tcl_GetStringFromObj(objv[1], &n);
+
+ if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) {
+ pattern = Tcl_GetString(objv[2]);
+ } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) {
+ regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
+ if (!regexp) {
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown option \"%s\"", what));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL);
+ return TCL_ERROR;
+ }
+ } else if (objc == 2) {
+ pattern = Tcl_GetString(objv[1]);
+ }
+ 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.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+#ifdef _WIN32
+#define LIBRARY_SIZE 64
+#endif /* _WIN32 */
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+#ifdef _WIN32
+ 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(_WIN32)
+ hModule = TclWinGetTclInstance();
+ GetModuleFileNameW(hModule, wName, MAX_PATH);
+ WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
+
+ if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE)
+ if (ZipfsAppHookFindTclInit(
+ CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */
+
+ /*
+ * If we're configured to know about a ZIP archive we should use, do that.
+ */
+
+#ifdef CFG_RUNTIME_ZIPFILE
+ if (ZipfsAppHookFindTclInit(
+ CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ if (ZipfsAppHookFindTclInit(
+ CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+ if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) {
+ return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+ }
+#endif /* CFG_RUNTIME_ZIPFILE */
+
+ /*
+ * 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) {
+ pResult = Tcl_NewObj();
+ }
+ 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 Tcl_WideInt
+ZipChannelWideSeek(
+ void *instanceData,
+ Tcl_WideInt 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;
+}
+
+#ifndef TCL_NO_DEPRECATED
+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.
+ *
+ * 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,
+ int mode,
+ TCL_UNUSED(int) /*permissions*/)
+{
+ ZipEntry *z;
+ ZipChannel *info;
+ int i, ch, trunc, wr, flags = 0;
+ char cname[128];
+
+ if ((mode & O_APPEND)
+ || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) {
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("unsupported open mode", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL);
+ }
+ return NULL;
+ }
+ 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;
+ }
+ trunc = (mode & O_TRUNC) != 0;
+ wr = (mode & (O_WRONLY | O_RDWR)) != 0;
+ if ((z->compressMethod != ZIP_COMPMETH_STORED)
+ && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) {
+ ZIPFS_ERROR(interp, "unsupported compression method");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL);
+ }
+ goto error;
+ }
+ if (wr && z->isDirectory) {
+ ZIPFS_ERROR(interp, "unsupported file type");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL);
+ }
+ goto error;
+ }
+ if (!trunc) {
+ flags |= TCL_READABLE;
+ if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) {
+ ZIPFS_ERROR(interp, "decryption failed");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL);
+ }
+ goto error;
+ } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) {
+ ZIPFS_ERROR(interp, "file too large");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
+ }
+ goto error;
+ }
+ } else {
+ flags = TCL_WRITABLE;
+ }
+ info = (ZipChannel *)attemptckalloc(sizeof(ZipChannel));
+ if (!info) {
+ ZIPFS_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ goto error;
+ }
+ info->zipFilePtr = z->zipFilePtr;
+ info->zipEntryPtr = z;
+ info->numRead = 0;
+ if (wr) {
+ flags |= TCL_WRITABLE;
+ info->isWriting = 1;
+ info->isDirectory = 0;
+ info->maxWrite = ZipFS.wrmax;
+ info->iscompr = 0;
+ info->isEncrypted = 0;
+ info->ubuf = (unsigned char *)attemptckalloc(info->maxWrite);
+ if (!info->ubuf) {
+ merror0:
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ckfree(info);
+ ZIPFS_ERROR(interp, "out of memory");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ goto error;
+ }
+ memset(info->ubuf, 0, info->maxWrite);
+ if (trunc) {
+ info->numBytes = 0;
+ } else if (z->data) {
+ unsigned int j = z->numBytes;
+
+ if (j > info->maxWrite) {
+ j = info->maxWrite;
+ }
+ memcpy(info->ubuf, z->data, j);
+ info->numBytes = j;
+ } else {
+ 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;
+ unsigned char *cbuf = NULL;
+
+ 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 merror0;
+ }
+ 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 cerror0;
+ }
+ 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);
+ }
+ goto wrapchan;
+ }
+ cerror0:
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ckfree(info);
+ ZIPFS_ERROR(interp, "decompression error");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
+ }
+ goto error;
+ } else if (z->isEncrypted) {
+ for (i = 0; i < z->numBytes - 12; i++) {
+ ch = zbuf[i];
+ info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ memcpy(info->ubuf, zbuf, z->numBytes);
+ }
+ memset(info->keys, 0, sizeof(info->keys));
+ goto wrapchan;
+ }
+ } else if (z->data) {
+ flags |= TCL_READABLE;
+ info->isWriting = 0;
+ info->iscompr = 0;
+ info->isDirectory = 0;
+ info->isEncrypted = 0;
+ info->numBytes = z->numBytes;
+ info->maxWrite = 0;
+ info->ubuf = z->data;
+ } else {
+ flags |= TCL_READABLE;
+ info->isWriting = 0;
+ 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;
+ info->maxWrite = 0;
+ 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 char *ubuf = NULL;
+ unsigned int j;
+
+ 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 merror;
+ }
+ 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) {
+ merror:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ ckfree(info);
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("out of memory", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
+ }
+ goto error;
+ }
+ stream.avail_out = info->numBytes;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto cerror;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+ if ((err == Z_STREAM_END)
+ || ((err == Z_OK) && (stream.avail_in == 0))) {
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ goto wrapchan;
+ }
+ cerror:
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ if (info->ubuf) {
+ ckfree(info->ubuf);
+ }
+ ckfree(info);
+ ZIPFS_ERROR(interp, "decompression error");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
+ }
+ goto error;
+ } else if (info->isEncrypted) {
+ unsigned char *ubuf = NULL;
+ 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) {
+ ckfree((char *) info);
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("out of memory", -1));
+ }
+ goto error;
+ }
+ for (j = 0; j < len; j++) {
+ ch = info->ubuf[j];
+ ubuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ info->ubuf = ubuf;
+ info->isEncrypted = 0;
+ }
+ }
+
+ wrapchan:
+ sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset,
+ ZipFS.idCount++);
+ z->zipFilePtr->numOpen++;
+ Unlock();
+ return Tcl_CreateChannel(&ZipChannelType, cname, info, flags);
+
+ error:
+ Unlock();
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipFSOpenFileChannelProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *pathPtr,
+ int mode,
+ int permissions)
+{
+ int len;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return NULL;
+ }
+ return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode,
+ permissions);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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)
+{
+ int len;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), 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)
+{
+ int len;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), 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);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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,
+ Tcl_Obj *pathPtr,
+ const char *pattern,
+ Tcl_GlobTypeData *types)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ int scnt, l, dirOnly = -1, prefixLen, strip = 0;
+ size_t len;
+ char *pat, *prefix, *path;
+ Tcl_DString dsPref;
+
+ if (!normPathPtr) {
+ return -1;
+ }
+ if (types) {
+ dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
+ }
+
+ /*
+ * The prefix that gets prepended to results.
+ */
+
+ prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen);
+
+ /*
+ * The (normalized) path we're searching.
+ */
+
+ path = Tcl_GetString(normPathPtr);
+ len = normPathPtr->length;
+
+ Tcl_DStringInit(&dsPref);
+ Tcl_DStringAppend(&dsPref, prefix, prefixLen);
+
+ if (strcmp(prefix, path) == 0) {
+ prefix = NULL;
+ } else {
+ strip = len + 1;
+ }
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, "/", 1);
+ prefixLen++;
+ prefix = Tcl_DStringValue(&dsPref);
+ }
+ ReadLock();
+ if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) {
+ 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;
+
+ 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)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, z->name, lenz);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(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)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, zf->mountPoint,
+ zf->mountPointLen);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(zf->mountPoint,
+ zf->mountPointLen));
+ }
+ }
+ }
+ goto end;
+ }
+
+ if (!pattern || (pattern[0] == '\0')) {
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
+ if (hPtr) {
+ ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
+
+ if ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
+ || (dirOnly && z->isDirectory)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, z->name, -1);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ }
+ goto end;
+ }
+
+ 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)) {
+ if (prefix) {
+ Tcl_DStringAppend(&dsPref, z->name + strip, -1);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
+ Tcl_DStringLength(&dsPref)));
+ Tcl_DStringSetLength(&dsPref, prefixLen);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(z->name + strip, -1));
+ }
+ }
+ }
+ ckfree(pat);
+
+ end:
+ Unlock();
+ Tcl_DStringFree(&dsPref);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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;
+ size_t len;
+ char *path;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+
+ path = Tcl_GetString(pathPtr);
+ if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) {
+ return -1;
+ }
+
+ len = pathPtr->length;
+
+ 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 ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) {
+ ret = TCL_OK;
+ goto endloop;
+ }
+ }
+ } else if ((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.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static const char *const *
+ZipFSFileAttrStringsProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
+ TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/)
+{
+ static const char *const attrs[] = {
+ "-uncompsize",
+ "-compsize",
+ "-offset",
+ "-mount",
+ "-archive",
+ "-permissions",
+ 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 = Tcl_GetStringFromObj(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 0:
+ *objPtrRef = Tcl_NewWideIntObj(z->numBytes);
+ break;
+ case 1:
+ *objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes);
+ break;
+ case 2:
+ *objPtrRef = Tcl_NewWideIntObj(z->offset);
+ break;
+ case 3:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
+ z->zipFilePtr->mountPointLen);
+ break;
+ case 4:
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1);
+ break;
+ case 5:
+ *objPtrRef = Tcl_NewStringObj("0o555", -1);
+ break;
+ default:
+ ZIPFS_ERROR(interp, "unknown attribute");
+ 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*/)
+{
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL);
+ }
+ 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 > 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);
+ Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,
+ TCL_LINK_INT);
+ 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, "zipfs", "2.0");
+ }
+ return TCL_OK;
+#else /* !HAVE_ZLIB */
+ ZIPFS_ERROR(interp, "no zlib available");
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ return TCL_ERROR;
+#endif /* HAVE_ZLIB */
+}
+
+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;
+}
+
+static void
+ZipfsExitHandler(
+ ClientData clientData)
+{
+ ZipFile *zf = (ZipFile *)clientData;
+
+ if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
+ Tcl_Panic("tried to unmount busy filesystem");
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_AppHook --
+ *
+ * Performs the argument munging for the shell
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+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 */
+{
+ char *archive;
+
+#ifdef _WIN32
+ Tcl_FindExecutable(NULL);
+#else
+ Tcl_FindExecutable((*argvPtr)[0]);
+#endif
+ archive = (char *) 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 TCL_OK;
+ }
+ }
+#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 TCL_OK;
+ } 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 TCL_OK;
+ }
+ }
+#ifdef _WIN32
+ Tcl_DStringFree(&ds);
+#endif /* _WIN32 */
+#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
+ }
+ return TCL_OK;
+}
+
+#ifndef HAVE_ZLIB
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount --
+ *
+ * Dummy version when no ZLIB support available.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ const char *mountPoint, /* Mount point path. */
+ const char *zipname, /* Path to ZIP file to mount. */
+ const char *passwd) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint, /* Mount point path. */
+ unsigned char *data,
+ size_t datalen,
+ int copy)
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ const char *mountPoint) /* Mount point path. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ if (interp) {
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
+ }
+ return TCL_ERROR;
+}
+#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 604ce64..e70c4b3 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -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.
@@ -205,8 +205,8 @@ static void ZlibTransformTimerRun(ClientData clientData);
static const Tcl_ChannelType zlibChannelType = {
"zlib",
- TCL_CHANNEL_VERSION_3,
- ZlibTransformClose,
+ TCL_CHANNEL_VERSION_5,
+ 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,
@@ -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[] = {
@@ -441,7 +442,7 @@ GenerateHeader(
if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
- valueStr = Tcl_GetStringFromObj(value, &len);
+ valueStr = TclGetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
NULL);
@@ -462,7 +463,7 @@ GenerateHeader(
if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
- valueStr = Tcl_GetStringFromObj(value, &len);
+ valueStr = TclGetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL);
headerPtr->nativeFilenameBuf[len] = '\0';
@@ -486,10 +487,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;
@@ -566,10 +568,10 @@ ExtractHeader(
SetValue(dictObj, "filename", TclDStringToObj(&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",
@@ -883,7 +885,7 @@ Tcl_ZlibStreamInit(
static void
ZlibStreamCmdDelete(
- ClientData cd)
+ void *cd)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
@@ -1151,6 +1153,11 @@ Tcl_ZlibStreamSetCompressionDictionary(
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ if (compressionDictionaryObj && (NULL == TclGetBytesFromObj(NULL,
+ compressionDictionaryObj, NULL))) {
+ /* Missing or invalid compression dictionary */
+ compressionDictionaryObj = NULL;
+ }
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
@@ -1190,6 +1197,7 @@ Tcl_ZlibStreamPut(
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize, toStore;
+ unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
@@ -1200,8 +1208,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;
/*
@@ -1325,7 +1338,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) {
@@ -1516,7 +1531,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;
@@ -1525,7 +1540,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;
@@ -1573,6 +1588,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.
*/
@@ -1616,12 +1641,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;
@@ -1722,6 +1741,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.
@@ -1759,7 +1783,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.
@@ -1859,7 +1882,7 @@ Tcl_ZlibInflate(
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
SetValue(gzipHeaderDictObj, "size",
- Tcl_NewLongObj(stream.total_out));
+ Tcl_NewWideIntObj(stream.total_out));
ckfree(nameBuf);
ckfree(commentBuf);
}
@@ -1919,7 +1942,7 @@ Tcl_ZlibAdler32(
static int
ZlibCmd(
- ClientData notUsed,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1955,6 +1978,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;
@@ -1962,7 +1989,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;
@@ -1972,6 +1998,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;
@@ -1979,7 +2009,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;
@@ -2312,6 +2341,12 @@ ZlibStreamSubcmd(
return TCL_ERROR;
}
+ if (compDictObj) {
+ if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
+ return TCL_ERROR;
+ }
+ }
+
/*
* Construct the stream now we know its configuration.
*/
@@ -2489,6 +2524,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;
@@ -2515,7 +2554,7 @@ ZlibPushSubcmd(
static int
ZlibStreamCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2618,7 +2657,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) {
@@ -2641,7 +2680,7 @@ ZlibStreamCmd(
static int
ZlibStreamAddCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2734,7 +2773,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;
}
@@ -2765,7 +2807,7 @@ ZlibStreamAddCmd(
static int
ZlibStreamPutCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2838,7 +2880,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;
}
@@ -2854,7 +2898,7 @@ ZlibStreamPutCmd(
static int
ZlibStreamHeaderCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2893,12 +2937,17 @@ ZlibStreamHeaderCmd(
static int
ZlibTransformClose(
- ClientData instanceData,
- Tcl_Interp *interp)
+ void *instanceData,
+ Tcl_Interp *interp,
+ int flags)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
int e, written, result = TCL_OK;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
/*
* Delete the support timer.
*/
@@ -2932,7 +2981,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 */
@@ -2992,7 +3041,7 @@ ZlibTransformClose(
static int
ZlibTransformInput(
- ClientData instanceData,
+ void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -3010,7 +3059,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) {
@@ -3127,7 +3176,7 @@ copyDecompressed:
static int
ZlibTransformOutput(
- ClientData instanceData,
+ void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -3160,7 +3209,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;
}
@@ -3216,7 +3265,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)));
@@ -3248,7 +3297,7 @@ ZlibTransformFlush(
static int
ZlibTransformSetOption( /* not used */
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
@@ -3269,7 +3318,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);
}
@@ -3361,7 +3413,7 @@ ZlibTransformSetOption( /* not used */
static int
ZlibTransformGetOption(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
@@ -3417,7 +3469,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);
}
@@ -3481,7 +3533,7 @@ ZlibTransformGetOption(
static void
ZlibTransformWatch(
- ClientData instanceData,
+ void *instanceData,
int mask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3504,7 +3556,7 @@ ZlibTransformWatch(
static int
ZlibTransformEventHandler(
- ClientData instanceData,
+ void *instanceData,
int interestMask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3525,7 +3577,7 @@ ZlibTransformEventTimerKill(
static void
ZlibTransformTimerRun(
- ClientData clientData)
+ void *clientData)
{
ZlibChannelData *cd = (ZlibChannelData *)clientData;
@@ -3546,9 +3598,9 @@ ZlibTransformTimerRun(
static int
ZlibTransformGetHandle(
- ClientData instanceData,
+ void *instanceData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3567,7 +3619,7 @@ ZlibTransformGetHandle(
static int
ZlibTransformBlockMode(
- ClientData instanceData,
+ void *instanceData,
int mode)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3683,7 +3735,7 @@ ZlibStackChannelTransform(
if (cd->inAllocated < cd->readAheadLimit) {
cd->inAllocated = cd->readAheadLimit;
}
- cd->inBuffer = ckalloc(cd->inAllocated);
+ cd->inBuffer = (char *)ckalloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) {
goto error;
@@ -3895,6 +3947,12 @@ TclZlibInit(
Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
+ * Allow command type introspection to do something sensible with streams.
+ */
+
+ TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
+
+ /*
* Formally provide the package as a Tcl built-in.
*/
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 a7a8979..7ef5681 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -74,6 +74,57 @@ 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 [string tolower $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 {[string tolower $dllpkg] ne [string tolower $basename]} continue
+ if {$dllfile eq {}} {
+ # Loaded statically
+ break
+ }
+ set found 1
+ zipfs mount $mountpoint $dllfile
+ break
+ }
+ if {!$found} {
+ set paths {}
+ lappend paths [file join $root app]
+ lappend paths [::${basename}::pkgconfig get libdir,runtime]
+ lappend paths [::${basename}::pkgconfig get bindir,runtime]
+ if {[catch {::${basename}::pkgconfig get zipfile,runtime} zipfile]} {
+ set zipfile [string tolower \
+ "lib${basename}_[join [list {*}[split $version .] {*}$patch] _].zip"]
+ }
+ lappend paths [file dirname [file join [pwd] [info nameofexecutable]]]
+ foreach path $paths {
+ set archive [file join $path $zipfile]
+ 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.
diff --git a/library/cookiejar/cookiejar.tcl b/library/cookiejar/cookiejar.tcl
new file mode 100644
index 0000000..6c8e82b
--- /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 \
+ http://publicsuffix.org/list/effective_tld_names.dat
+ variable domainfile \
+ [file join [file dirname [info script]] effective_tld_names.txt.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 "\u0000\u0000"} {optionValue "\u0000\u0000"}} {
+ 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 "\u0000\u0000"} {
+ 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 "\u0000\u0000"} {
+ {*}$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/effective_tld_names.txt.gz b/library/cookiejar/effective_tld_names.txt.gz
new file mode 100644
index 0000000..13e08bb
--- /dev/null
+++ b/library/cookiejar/effective_tld_names.txt.gz
Binary files differ
diff --git a/library/cookiejar/idna.tcl b/library/cookiejar/idna.tcl
new file mode 100644
index 0000000..afc7128
--- /dev/null
+++ b/library/cookiejar/idna.tcl
@@ -0,0 +1,292 @@
+# cookiejar.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 (c) 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 "\u002E\u3002\uFF0E\uFF61"] {
+ if {[regexp {[^-A-Za-z0-9]} $part]} {
+ if {[regexp {[^-A-Za-z0-9\u00a1-\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 "\u002E\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 < "\u0080"} {
+ 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/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index b7187c0..e8917ac 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,4 +1,4 @@
-if {![package vsatisfies [package provide Tcl] 8.5]} return
+if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded dde 1.4.3 [list load [file join $dir tcldde14g.dll] dde]
diff --git a/library/http/http.tcl b/library/http/http.tcl
index a93e67b..a7ed771 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -20,6 +20,7 @@ namespace eval http {
if {![info exists http]} {
array set http {
-accept */*
+ -cookiejar {}
-pipeline 1
-postfresh 0
-proxyhost {}
@@ -127,6 +128,18 @@ namespace eval http {
set defaultKeepalive 0
}
+ # 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
+ )?
+ }
+
namespace export geturl config reset wait formatQuery quoteString
namespace export register unregister registerError
# - Useful, but not exported: data, size, status, code, cleanup, error,
@@ -892,8 +905,12 @@ proc http::geturl {url args} {
}
return -code error "Illegal characters in URL path"
}
+ if {![regexp {^[^?#]+} $srvurl state(path)]} {
+ set state(path) /
+ }
} else {
set srvurl /
+ set state(path) /
}
if {$proto eq ""} {
set proto http
@@ -1352,12 +1369,16 @@ proc http::Connected {token proto phost srvurl} {
puts $sock "$how $srvurl HTTP/$state(-protocol)"
if {[dict exists $state(-headers) Host]} {
# Allow Host spoofing. [Bug 928154]
- puts $sock "Host: [dict get $state(-headers) Host]"
+ set hostHdr [dict get $state(-headers) Host]
+ regexp {^[^:]+} $hostHdr state(host)
+ puts $sock "Host: $hostHdr"
} elseif {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# #504508]
+ set state(host) $host
puts $sock "Host: $host"
} else {
+ set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
@@ -1419,6 +1440,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 ""} {
+ puts $sock "Cookie: $cookies"
+ }
+ }
+
# Flush the request header and set up the fileevent that will either
# push the POST data or read the response.
#
@@ -2691,6 +2728,11 @@ proc http::Event {sock token} {
set state(connection) \
[string trim [string tolower $value]]
}
+ set-cookie {
+ if {$http(-cookiejar) ne ""} {
+ ParseCookie $token [string trim $value]
+ }
+ }
}
lappend state(meta) $key [string trim $value]
}
@@ -2988,6 +3030,83 @@ proc http::IsBinaryContentType {type} {
return true
}
+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.
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 e6964e0..e62d05d 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -6,7 +6,10 @@
# 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 by Kevin B. Kenny. All rights reserved.
+# Copyright (c) 2004 by Kevin B. Kenny.
+# Copyright (c) 2018 by 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.10
+package require -exact Tcl 8.7a4
# 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 \
- "too few 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 \
- "too few 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
@@ -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
@@ -505,7 +453,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"
@@ -679,10 +627,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} {
diff --git a/library/install.tcl b/library/install.tcl
new file mode 100644
index 0000000..e62226e
--- /dev/null
+++ b/library/install.tcl
@@ -0,0 +1,244 @@
+###
+# 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]
+ 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]
+ 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]
+ 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 master
+ # 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 0644
+ } else {
+ file attributes [file join $d2 $ftail] -readonly 1
+ }
+ }
+ }
+
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes $d2 -permissions 0755
+ } 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..5ae0eb7
--- /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.9.2 {http http.tcl}
+ 1 msgcat 1.7.1 {msgcat msgcat.tcl}
+ 1 opt 0.4.7 {opt optparse.tcl}
+ 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl}
+ 0 tcl::idna 1.0.1 {cookiejar idna.tcl}
+ 0 platform 1.0.14 {platform platform.tcl}
+ 0 platform::shell 1.1.4 {platform shell.tcl}
+ 1 tcltest 2.5.3 {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 646bc17..b488b9c 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 by Harald Oehlmann.
+# Copyright (c) 2010-2018 by Harald Oehlmann.
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by 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"} {
@@ -179,12 +187,35 @@ namespace eval msgcat {
# Find the translation for the given string based on the current
# locale setting. Check the local 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 traslated
+# 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:
+# 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::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
#
@@ -192,10 +223,7 @@ 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::mcn {ns src args} {
# Check for the src in each namespace starting from the local and
# ending in the global.
@@ -203,7 +231,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 +246,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 +272,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 +338,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 +381,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 +509,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 +517,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 +557,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 +648,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 +658,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 +722,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 +862,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 +1028,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 +1056,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 +1080,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 +1107,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 --
@@ -1013,7 +1118,7 @@ proc msgcat::mcflmset {pairs} {
# by an application specific routine for error reporting
# purposes. The default behavior is to return the source string.
# If additional args are specified, the format command will be used
-# to work them into the traslated string.
+# to work them into the translated string.
#
# Arguments:
# locale The current locale.
@@ -1024,7 +1129,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 --
@@ -1034,9 +1139,9 @@ proc msgcat::mcunknown {args} {
# - Default global handler, if mcunknown is not redefined.
# - Per package handler, if the package sets unknowncmd to the empty
# string.
-# It returna the source string if the argument list is empty.
+# It returns the source string if the argument list is empty.
# If additional args are specified, the format command will be used
-# to work them into the traslated string.
+# to work them into the translated string.
#
# Arguments:
# locale (unused) The current locale.
@@ -1067,8 +1172,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 +1185,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 +1212,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 +1253,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 +1262,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 +1272,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 +1281,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 +1303,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 +1313,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 +1328,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 44e3b28..6c87ec1 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -488,12 +488,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
}
@@ -506,11 +510,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
@@ -590,11 +598,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/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl
index f2fb3b7..b33970d 100644
--- a/library/reg/pkgIndex.tcl
+++ b/library/reg/pkgIndex.tcl
@@ -1,4 +1,4 @@
-if {![package vsatisfies [package provide Tcl] 8.5]} return
+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 \
diff --git a/library/safe.tcl b/library/safe.tcl
index 3429b9e..470cfa3 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -455,37 +455,35 @@ proc ::safe::InterpInit {
foreach {command alias} {
source AliasSource
load AliasLoad
- encoding AliasEncoding
exit interpDelete
glob AliasGlob
} {
::interp alias $slave $command {} [namespace current]::$alias $slave
}
+ # 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 $slave $command {} interp invokehidden $slave $command
+ }
+
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- ::interp expose $slave file
foreach subcommand {dirname extension rootname tail} {
::interp alias $slave ::tcl::file::$subcommand {} \
::safe::AliasFileSubcommand $slave $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 $slave ::tcl::file::$subcommand {} \
- ::safe::BadSubcommand $slave file $subcommand
- }
+
+ # Subcommand of 'encoding' that has special handling; [encoding system] is
+ # OK provided it has no other arguments passed to it.
+ ::interp alias $slave ::tcl::encoding::system {} \
+ ::safe::AliasEncodingSystem $slave
# Subcommands of info
- foreach {subcommand alias} {
- nameofexecutable AliasExeName
- } {
- ::interp alias $slave ::tcl::info::$subcommand \
- {} [namespace current]::$alias $slave
- }
+ ::interp alias $slave ::tcl::info::nameofexecutable {} \
+ ::safe::AliasExeName $slave
# The allowed slave variables already have been set by Tcl_MakeSafe(3)
@@ -1027,16 +1025,13 @@ proc ::safe::BadSubcommand {slave 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 {slave option args} {
- # Note that [encoding dirs] is not supported in safe slaves at all
- set subcommands {convertfrom convertto names system}
+# AliasEncodingSystem is the target of the "encoding system" alias in safe
+# interpreters.
+proc ::safe::AliasEncodingSystem {slave 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 slaves 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\""
}
@@ -1044,7 +1039,7 @@ proc ::safe::AliasEncoding {slave option args} {
Log $slave $msg
return -options $options $msg
}
- tailcall ::interp invokehidden $slave encoding $option {*}$args
+ tailcall ::interp invokehidden $slave tcl:encoding:system
}
# Various minor hiding of platform features. [Bug 2913625]
diff --git a/library/tclIndex b/library/tclIndex
index 0409d9b..87a2814 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -7,72 +7,69 @@
# 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::slavehook) [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(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/word.tcl b/library/word.tcl
index 3e4bc3a..0246530 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -11,24 +11,14 @@
# 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/appveyor.yml b/libtommath/appveyor.yml
index 187a09a..08bb013 100644
--- a/libtommath/appveyor.yml
+++ b/libtommath/appveyor.yml
@@ -4,6 +4,7 @@ branches:
- master
- develop
- /^release/
+ - /^support/
- /^travis/
image:
- Visual Studio 2019
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 f507b1d..b86d789 100644
--- a/libtommath/bn_mp_log_u32.c
+++ b/libtommath/bn_mp_log_u32.c
@@ -6,7 +6,7 @@
/* Compute log_{base}(a) */
static mp_word s_pow(mp_word base, mp_word exponent)
{
- mp_word result = 1;
+ mp_word result = 1u;
while (exponent != 0u) {
if ((exponent & 1u) == 1u) {
result *= base;
@@ -20,8 +20,8 @@ static mp_word s_pow(mp_word base, mp_word exponent)
static mp_digit s_digit_ilogb(mp_digit base, mp_digit n)
{
- mp_word bracket_low = 1, bracket_mid, bracket_high, N;
- mp_digit ret, high = 1uL, low = 0uL, mid;
+ mp_word bracket_low = 1u, bracket_mid, bracket_high, N;
+ mp_digit ret, high = 1u, low = 0uL, mid;
if (n < base) {
return 0uL;
@@ -40,7 +40,7 @@ static mp_digit s_digit_ilogb(mp_digit base, mp_digit n)
bracket_high *= bracket_high;
}
- while (((mp_digit)(high - low)) > 1uL) {
+ while (((mp_digit)(high - low)) > 1u) {
mid = (low + high) >> 1;
bracket_mid = bracket_low * s_pow(base, (mp_word)(mid - low));
@@ -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_set_double.c b/libtommath/bn_mp_set_double.c
index a42fc70..7f1ab75 100644
--- a/libtommath/bn_mp_set_double.c
+++ b/libtommath/bn_mp_set_double.c
@@ -16,7 +16,7 @@ mp_err mp_set_double(mp_int *a, double b)
cast.dbl = b;
exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFu);
- frac = (cast.bits & ((1uLL << 52) - 1uLL)) | (1uLL << 52);
+ frac = (cast.bits & (((uint64_t)1 << 52) - (uint64_t)1)) | ((uint64_t)1 << 52);
if (exp == 0x7FF) { /* +-inf, NaN */
return MP_VAL;
@@ -30,7 +30,7 @@ mp_err mp_set_double(mp_int *a, double b)
return err;
}
- if (((cast.bits >> 63) != 0uLL) && !MP_IS_ZERO(a)) {
+ if (((cast.bits >> 63) != 0u) && !MP_IS_ZERO(a)) {
a->sign = MP_NEG;
}
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/bn_s_mp_mul_high_digs_fast.c b/libtommath/bn_s_mp_mul_high_digs_fast.c
index a2c4fb6..a0513b4 100644
--- a/libtommath/bn_s_mp_mul_high_digs_fast.c
+++ b/libtommath/bn_s_mp_mul_high_digs_fast.c
@@ -3,8 +3,8 @@
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
-/* this is a modified version of fast_s_mul_digs that only produces
- * output digits *above* digs. See the comments for fast_s_mul_digs
+/* this is a modified version of s_mp_mul_digs_fast that only produces
+ * output digits *above* digs. See the comments for s_mp_mul_digs_fast
* to see how it works.
*
* This is used in the Barrett reduction since for one of the multiplications
diff --git a/libtommath/bn_s_mp_rand_jenkins.c b/libtommath/bn_s_mp_rand_jenkins.c
index da0771c..c64afac 100644
--- a/libtommath/bn_s_mp_rand_jenkins.c
+++ b/libtommath/bn_s_mp_rand_jenkins.c
@@ -27,10 +27,10 @@ static uint64_t s_rand_jenkins_val(void)
void s_mp_rand_jenkins_init(uint64_t seed)
{
- uint64_t i;
+ int i;
jenkins_x.a = 0xf1ea5eedULL;
jenkins_x.b = jenkins_x.c = jenkins_x.d = seed;
- for (i = 0uLL; i < 20uLL; ++i) {
+ for (i = 0; i < 20; ++i) {
(void)s_rand_jenkins_val();
}
}
diff --git a/libtommath/changes.txt b/libtommath/changes.txt
index ebf7382..1b3a7a3 100644
--- a/libtommath/changes.txt
+++ b/libtommath/changes.txt
@@ -1,4 +1,4 @@
-XXX XXth, 2019
+Oct 22nd, 2019
v1.2.0
-- A huge refactoring of the library happened - renaming,
deprecating and replacing existing functions by improved API's.
diff --git a/libtommath/helper.pl b/libtommath/helper.pl
index e60c1a7..c624b7c 100755
--- a/libtommath/helper.pl
+++ b/libtommath/helper.pl
@@ -51,7 +51,7 @@ sub check_source {
push @{$troubles->{tab}}, $lineno if $l =~ /\t/ && basename($file) !~ /^makefile/i;
push @{$troubles->{non_ascii_char}}, $lineno if $l =~ /[^[:ascii:]]/;
push @{$troubles->{cpp_comment}}, $lineno if $file =~ /\.(c|h)$/ && ($l =~ /\s\/\// || $l =~ /\/\/\s/);
- # we prefer using XMALLOC, XFREE, XREALLOC, XCALLOC ...
+ # we prefer using MP_MALLOC, MP_FREE, MP_REALLOC, MP_CALLOC ...
push @{$troubles->{unwanted_malloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmalloc\s*\(/;
push @{$troubles->{unwanted_realloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\brealloc\s*\(/;
push @{$troubles->{unwanted_calloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bcalloc\s*\(/;
diff --git a/libtommath/makefile_include.mk b/libtommath/makefile_include.mk
index 7b025e8..452d37d 100644
--- a/libtommath/makefile_include.mk
+++ b/libtommath/makefile_include.mk
@@ -116,10 +116,10 @@ endif
# adjust coverage set
ifneq ($(filter $(_ARCH), i386 i686 x86_64 amd64 ia64),)
- COVERAGE = test_standalone timing
+ COVERAGE = test timing
COVERAGE_APP = ./test && ./timing
else
- COVERAGE = test_standalone
+ COVERAGE = test
COVERAGE_APP = ./test
endif
@@ -135,6 +135,10 @@ LIBPATH ?= $(PREFIX)/lib
INCPATH ?= $(PREFIX)/include
DATAPATH ?= $(PREFIX)/share/doc/libtommath/pdf
+# build & run test-suite
+check: test
+ ./test
+
#make the code coverage of the library
#
coverage: LTM_CFLAGS += -fprofile-arcs -ftest-coverage -DTIMING_NO_LOGS
diff --git a/libtommath/tommath.h b/libtommath/tommath.h
index 22951c9..8f2867e 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
@@ -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.
@@ -236,13 +237,22 @@ TOOM_SQR_CUTOFF;
#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(x) __declspec(deprecated("replaced by " #x))
# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
-#else
-# define MP_DEPRECATED(s)
+#endif
+#endif
+
+#ifndef MP_DEPRECATED_PRAGMA
# define MP_DEPRECATED_PRAGMA(s)
#endif
@@ -252,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);
@@ -304,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;
@@ -327,9 +340,12 @@ 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;
+#ifdef _MSC_VER
+#define mp_get_mag_ull(a) ((unsigned __int64)mp_get_mag_u64(a))
+#else
+unsigned long long mp_get_mag_ull(const mp_int *a) MP_WUR;
+#endif
/* get integer, set integer (long) */
long mp_get_l(const mp_int *a) MP_WUR;
@@ -341,15 +357,27 @@ 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;
+#ifdef _MSC_VER
+/* get integer, set integer (long long) */
+#define mp_get_ll(a) ((__int64)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 __int64)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)
+#else
+/* get integer, set integer (long long) */
+long long mp_get_ll(const mp_int *a) MP_WUR;
+void mp_set_ll(mp_int *a, long long b);
+mp_err mp_init_ll(mp_int *a, long long b) MP_WUR;
+
+/* get integer, set integer (unsigned long long) */
+#define mp_get_ull(a) ((unsigned long long)mp_get_ll(a))
+void mp_set_ull(mp_int *a, unsigned long long b);
+mp_err mp_init_ull(mp_int *a, unsigned long long b) MP_WUR;
+#endif
/* set to single unsigned digit, up to MP_DIGIT_MAX */
void mp_set(mp_int *a, mp_digit b);
@@ -358,10 +386,14 @@ 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;
+#ifdef _MSC_VER
+MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) unsigned __int64 mp_get_long_long(const mp_int *a) MP_WUR;
+#endif
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);
+#ifdef _MSC_VER
+MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, unsigned __int64 b);
+#endif
MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
/* copy, b = a */
@@ -558,7 +590,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;
@@ -721,10 +753,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/libtommath.dll b/libtommath/win64/libtommath.dll
new file mode 100755
index 0000000..2225faf
--- /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..40adaf7
--- /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 100755
index 0000000..434fa7c
--- /dev/null
+++ b/libtommath/win64/tommath.lib
Binary files differ
diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile
index 56e5500..9d82e42 100644
--- a/macosx/GNUmakefile
+++ b/macosx/GNUmakefile
@@ -92,7 +92,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
@@ -132,7 +132,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 \
${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi
build-${PROJECT}: ${objdir}/Makefile
diff --git a/macosx/README b/macosx/README
index c944c0a..f28c055 100644
--- a/macosx/README
+++ b/macosx/README
@@ -113,7 +113,7 @@ The following build configurations are available:
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.
@@ -134,9 +134,9 @@ 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"
If you are building from CVS, omit this step (CVS source tree names usually do
not contain a version number).
diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig
index 9c47547..0670479 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 -Wwrite-strings -Wextra -Wdeclaration-after-statement -Wno-unused-parameter -Wno-missing-field-initializers -Wno-unused-value -Winit-self -Wpointer-arith -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/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj
index 788aa8d..a83d100 100644
--- a/macosx/Tcl.xcode/project.pbxproj
+++ b/macosx/Tcl.xcode/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 */; };
@@ -165,6 +164,7 @@
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 */; };
+ F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.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 */; };
@@ -534,7 +534,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>"; };
@@ -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,8 +763,7 @@
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>"; };
@@ -788,7 +785,7 @@
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 +829,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>"; };
@@ -1322,7 +1319,6 @@
F96D3F3508F272A7004A47F5 /* tclUtil.c */,
F96D3F3608F272A7004A47F5 /* tclVar.c */,
F96437C90EF0D4B2003F468E /* tclZlib.c */,
- F96D3F3708F272A7004A47F5 /* tommath.h */,
);
path = generic;
sourceTree = "<group>";
@@ -1436,6 +1432,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 +1467,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 */,
@@ -1658,8 +1654,7 @@
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D43D208F272B8004A47F5 /* configure */,
- F96D43D308F272B8004A47F5 /* configure.in */,
- F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */,
+ F96D43D308F272B8004A47F5 /* configure.ac */,
F96D442508F272B8004A47F5 /* genStubs.tcl */,
F96D442708F272B8004A47F5 /* index.tcl */,
F96D442808F272B8004A47F5 /* installData.tcl */,
@@ -1689,7 +1684,7 @@
children = (
F96D444008F272B9004A47F5 /* aclocal.m4 */,
F96D444108F272B9004A47F5 /* configure */,
- F96D444208F272B9004A47F5 /* configure.in */,
+ F96D444208F272B9004A47F5 /* configure.ac */,
F96D444308F272B9004A47F5 /* dltest */,
F96D444D08F272B9004A47F5 /* install-sh */,
F96D444E08F272B9004A47F5 /* installManPage */,
@@ -1750,7 +1745,7 @@
F96D447208F272BA004A47F5 /* cat.c */,
F96D447308F272BA004A47F5 /* coffbase.txt */,
F96D447408F272BA004A47F5 /* configure */,
- F96D447508F272BA004A47F5 /* configure.in */,
+ F96D447508F272BA004A47F5 /* configure.ac */,
F96D447708F272BA004A47F5 /* Makefile.in */,
F96D447808F272BA004A47F5 /* makefile.vc */,
F96D447908F272BA004A47F5 /* nmakehlp.c */,
@@ -1936,7 +1931,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 +1944,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 +2060,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 +2095,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 */,
diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj
index 4362739..b1c3a39 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 */; };
@@ -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,8 +763,7 @@
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>"; };
@@ -788,7 +785,7 @@
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 +829,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>"; };
@@ -1322,7 +1319,6 @@
F96D3F3508F272A7004A47F5 /* tclUtil.c */,
F96D3F3608F272A7004A47F5 /* tclVar.c */,
F96437C90EF0D4B2003F468E /* tclZlib.c */,
- F96D3F3708F272A7004A47F5 /* tommath.h */,
);
path = generic;
sourceTree = "<group>";
@@ -1436,6 +1432,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 +1467,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 */,
@@ -1658,8 +1654,7 @@
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D43D208F272B8004A47F5 /* configure */,
- F96D43D308F272B8004A47F5 /* configure.in */,
- F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */,
+ F96D43D308F272B8004A47F5 /* configure.ac */,
F96D442508F272B8004A47F5 /* genStubs.tcl */,
F96D442708F272B8004A47F5 /* index.tcl */,
F96D442808F272B8004A47F5 /* installData.tcl */,
@@ -1689,7 +1684,7 @@
children = (
F96D444008F272B9004A47F5 /* aclocal.m4 */,
F96D444108F272B9004A47F5 /* configure */,
- F96D444208F272B9004A47F5 /* configure.in */,
+ F96D444208F272B9004A47F5 /* configure.ac */,
F96D444308F272B9004A47F5 /* dltest */,
F96D444D08F272B9004A47F5 /* install-sh */,
F96D444E08F272B9004A47F5 /* installManPage */,
@@ -1750,7 +1745,7 @@
F96D447208F272BA004A47F5 /* cat.c */,
F96D447308F272BA004A47F5 /* coffbase.txt */,
F96D447408F272BA004A47F5 /* configure */,
- F96D447508F272BA004A47F5 /* configure.in */,
+ F96D447508F272BA004A47F5 /* configure.ac */,
F96D447708F272BA004A47F5 /* Makefile.in */,
F96D447808F272BA004A47F5 /* makefile.vc */,
F96D447908F272BA004A47F5 /* nmakehlp.c */,
@@ -1936,7 +1931,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 +1944,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 +2060,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 +2095,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 */,
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 9fadb7b..af15287 100644
--- a/macosx/tclMacOSXBundle.c
+++ b/macosx/tclMacOSXBundle.c
@@ -12,6 +12,7 @@
*/
#include "tclPort.h"
+#include "tclInt.h"
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
@@ -106,7 +107,7 @@ OpenResourceMap(
if (tclMacOSXDarwinRelease >= 8)
#endif
{
- openresourcemap = dlsym(RTLD_NEXT,
+ openresourcemap = (short (*)(CFBundleRef))dlsym(RTLD_NEXT,
"CFBundleOpenBundleResourceMap");
#ifdef TCL_DEBUG_LOAD
if (!openresourcemap) {
@@ -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 f34b280..06ad180 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -106,7 +106,7 @@ typedef struct finderinfo {
u_int32_t extendedFileInfo[4];
} __attribute__ ((__packed__)) finderinfo;
-typedef struct fileinfobuf {
+typedef struct {
u_int32_t info_length;
u_int32_t data[8];
} fileinfobuf;
@@ -172,7 +172,7 @@ TclMacOSXGetFileAttribute(
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
- native = Tcl_FSGetNativePath(fileName);
+ native = (const char *)Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
@@ -192,7 +192,7 @@ TclMacOSXGetFileAttribute(
OSSwapBigToHostInt32(finder->type));
break;
case MACOSX_HIDDEN_ATTRIBUTE:
- *attributePtrPtr = Tcl_NewBooleanObj(
+ *attributePtrPtr = Tcl_NewWideIntObj(
(finder->fdFlags & kFinfoIsInvisible) != 0);
break;
case MACOSX_RSRCLENGTH_ATTRIBUTE:
@@ -268,7 +268,7 @@ TclMacOSXSetFileAttribute(
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
- native = Tcl_FSGetNativePath(fileName);
+ native = (const char *)Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
@@ -347,7 +347,7 @@ TclMacOSXSetFileAttribute(
Tcl_DStringAppend(&ds, native, -1);
Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1);
- result = truncate(Tcl_DStringValue(&ds), (off_t)0);
+ result = truncate(Tcl_DStringValue(&ds), 0);
if (result != 0) {
/*
* truncate() on a valid resource fork path may fail with a
@@ -577,10 +577,10 @@ GetOSTypeFromObj(
{
int result = TCL_OK;
- if (objPtr->typePtr != &tclOSTypeType) {
+ if (!TclHasIntRep(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) {
@@ -654,13 +654,13 @@ SetOSTypeFromAny(
OSType osType;
char bytes[4] = {'\0','\0','\0','\0'};
- memcpy(bytes, Tcl_DStringValue(&ds), (size_t)Tcl_DStringLength(&ds));
+ memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
osType = (OSType) bytes[0] << 24 |
(OSType) bytes[1] << 16 |
(OSType) bytes[2] << 8 |
(OSType) bytes[3];
TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = (long) osType;
+ objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
objPtr->typePtr = &tclOSTypeType;
}
Tcl_DStringFree(&ds);
@@ -689,27 +689,31 @@ SetOSTypeFromAny(
static void
UpdateStringOfOSType(
- register Tcl_Obj *objPtr) /* OSType object whose string rep to
+ 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, -1, /* 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 9b7bd1a..8f1dbba 100644
--- a/macosx/tclMacOSXNotify.c
+++ b/macosx/tclMacOSXNotify.c
@@ -31,6 +31,9 @@
*/
#if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK)
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#pragma GCC diagnostic ignored "-Wunused-function"
/*
* Use OSSpinLock API where available (Tiger or later).
*/
@@ -42,14 +45,17 @@
* Support for weakly importing spinlock API.
*/
#define WEAK_IMPORT_SPINLOCKLOCK
+
#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1050
#define VOLATILE volatile
#else
#define VOLATILE
#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 1050 */
+
#ifndef bool
#define bool int
#endif
+
extern void OSSpinLockLock(VOLATILE OSSpinLock *lock)
WEAK_IMPORT_ATTRIBUTE;
extern void OSSpinLockUnlock(VOLATILE OSSpinLock *lock)
@@ -77,13 +83,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
@@ -93,14 +140,37 @@ 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
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
/*
@@ -217,7 +287,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
@@ -232,7 +302,7 @@ typedef struct FileHandlerEvent {
* writable, and exceptional conditions.
*/
-typedef struct SelectMasks {
+typedef struct {
fd_set readable;
fd_set writable;
fd_set exceptional;
@@ -385,8 +455,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);
@@ -686,7 +755,7 @@ StartNotifierThread(void)
void
Tcl_FinalizeNotifier(
- ClientData clientData) /* Not used. */
+ ClientData clientData)
{
ThreadSpecificData *tsdPtr;
@@ -789,7 +858,7 @@ void
Tcl_AlertNotifier(
ClientData clientData)
{
- ThreadSpecificData *tsdPtr = clientData;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
@@ -873,8 +942,8 @@ Tcl_SetTimer(
static void
TimerWakeUp(
- CFRunLoopTimerRef timer,
- void *info)
+ TCL_UNUSED(CFRunLoopTimerRef),
+ TCL_UNUSED(ClientData))
{
}
@@ -967,7 +1036,7 @@ Tcl_CreateFileHandler(
}
}
if (filePtr == NULL) {
- filePtr = ckalloc(sizeof(FileHandler));
+ filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
@@ -1311,7 +1380,7 @@ QueueFileEvents(
{
SelectMasks readyMasks;
FileHandler *filePtr;
- ThreadSpecificData *tsdPtr = info;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
/*
* Queue all detected file events.
@@ -1350,7 +1419,7 @@ QueueFileEvents(
*/
if (filePtr->readyMask == 0) {
- FileHandlerEvent *fileEvPtr = ckalloc(sizeof(FileHandlerEvent));
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
@@ -1379,11 +1448,11 @@ QueueFileEvents(
static void
UpdateWaitingListAndServiceEvents(
- CFRunLoopObserverRef observer,
+ TCL_UNUSED(CFRunLoopObserverRef),
CFRunLoopActivity activity,
void *info)
{
- ThreadSpecificData *tsdPtr = info;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
if (tsdPtr->sleeping) {
return;
@@ -1412,7 +1481,10 @@ UpdateWaitingListAndServiceEvents(
(tsdPtr->runLoopNestingLevel > 1
|| !tsdPtr->runLoopRunning)) {
tsdPtr->runLoopServicingEvents = 1;
- /* This call seems to simply force event processing through and prevents hangups that have long been observed with Tk-Cocoa. */
+ /*
+ * This call seems to simply force event processing through and
+ * prevents hangups that have long been observed with Tk-Cocoa.
+ */
Tcl_ServiceAll();
tsdPtr->runLoopServicingEvents = 0;
}
@@ -1753,9 +1825,9 @@ TclUnixWaitForFile(
*----------------------------------------------------------------------
*/
-static void
+static TCL_NORETURN void
NotifierThreadProc(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask, writableMask, exceptionalMask;
diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl
index a715c8a..af8ee96 100644
--- a/tests-perf/test-performance.tcl
+++ b/tests-perf/test-performance.tcl
@@ -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/apply.test b/tests/apply.test
index ba19b81..597cd97 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -228,7 +228,7 @@ test apply-8.3 {args treatment} {
apply [list {x args} $applyBody] 1 2 3
} {{x 1} {args {2 3}}}
test apply-8.4 {default values} {
- apply [list {{x 1} {y 2}} $applyBody]
+ apply [list {{x 1} {y 2}} $applyBody]
} {{x 1} {y 2}}
test apply-8.5 {default values} {
apply [list {{x 1} {y 2}} $applyBody] 3 4
diff --git a/tests/assemble.test b/tests/assemble.test
index 45368de..5d86c47 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -12,7 +12,7 @@
# Commands covered: assemble
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
@@ -301,12 +301,12 @@ test assemble-7.1 {add, wrong # args} {
-result {wrong # args*}
}
test assemble-7.2 {add} {
- -body {
+ -body {
assemble {
push 2
push 2
add
- }
+ }
}
-result {4}
}
@@ -349,7 +349,7 @@ test assemble-7.5 {bitwise ops} {
}
test assemble-7.6 {div} {
-body {
- assemble {push 999999; push 7; div}
+ assemble {push 999999; push 7; div}
}
-result 142857
}
@@ -360,7 +360,7 @@ test assemble-7.7 {dup} {
}
}
-result 9
-}
+}
test assemble-7.8 {eq} {
-body {
list \
@@ -638,7 +638,7 @@ test assemble-7.24 {lsetList} {
test assemble-7.25 {lshift} {
-body {
assemble {push 16; push 4; lshift}
- }
+ }
-result 256
}
test assemble-7.26 {mod} {
@@ -678,7 +678,7 @@ test assemble-7.30 {pop} {
test assemble-7.31 {rshift} {
-body {
assemble {push 257; push 4; rshift}
- }
+ }
-result 16
}
test assemble-7.32 {storeArrayStk} {
@@ -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
@@ -1201,7 +1202,7 @@ test assemble-10.7 {expr - noncompilable} {
# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend,
# nsupvar, variable, upvar)
-
+
test assemble-11.1 {exist - wrong # args} {
-body {
assemble {exist}
@@ -1310,7 +1311,7 @@ test assemble-11.10 {variable} {
}
# assemble-12 - ASSEM_LVT1 (incr and incrArray)
-
+
test assemble-12.1 {incr - wrong # args} {
-body {
assemble {incr}
@@ -1723,16 +1724,16 @@ test assemble-17.9 {jump - resolve a label multiple times} {
set result {}
assemble {
jump common
-
+
label zero
- pop
+ pop
incrImm case 1
pop
push a
append result
pop
jump common
-
+
label one
pop
incrImm case 1
@@ -1741,7 +1742,7 @@ test assemble-17.9 {jump - resolve a label multiple times} {
append result
pop
jump common
-
+
label common
load case
dup
@@ -1760,7 +1761,7 @@ test assemble-17.9 {jump - resolve a label multiple times} {
push 3
eq
jumpTrue three
-
+
label two
pop
incrImm case 1
@@ -1769,7 +1770,7 @@ test assemble-17.9 {jump - resolve a label multiple times} {
append result
pop
jump common
-
+
label three
pop
incrImm case 1
@@ -1867,7 +1868,7 @@ test assemble-17.15 {multiple passes of code resizing} {
append body {label b15; push b; concat 2; nop; nop; jump c} \n
append body {label d}
proc x {} [list assemble $body]
- }
+ }
-body {
x
}
@@ -2060,7 +2061,7 @@ test assemble-20.5 {lsetFlat - negative operand count} {
test assemble-20.6 {lsetFlat} {
-body {
assemble {push b; push a; lsetFlat 2}
- }
+ }
-result b
}
test assemble-20.7 {lsetFlat} {
@@ -3046,12 +3047,12 @@ test assemble-40.1 {unbalanced stack} {
[catch {
assemble {
push 3
- dup
- mult
+ dup
+ mult
push 4
- dup
- mult
- pop
+ dup
+ mult
+ pop
expon
}
} result] $result $::errorInfo
@@ -3150,7 +3151,7 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} {
load n; # max
dup; # max n
jump start; # max n
-
+
label loop; # max n
over 1; # max n max
over 1; # max in max n
@@ -3160,29 +3161,29 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} {
reverse 2; # n max
pop; # n
dup; # n n
-
+
label skip; # max n
dup; # max n n
push 2; # max n n 2
mod; # max n n%2
jumpTrue odd; # max n
-
+
push 2; # max n 2
div; # max n/2 -> max n
jump start; # max n
-
+
label odd; # max n
push 3; # max n 3
mult; # max 3*n
push 1; # max 3*n 1
add; # max 3*n+1
-
+
label start; # max n
dup; # max n n
push 1; # max n n 1
neq; # max n n>1
jumpTrue loop; # max n
-
+
pop; # max
}
}
@@ -3212,7 +3213,7 @@ test assemble-51.3 {memory leak testing} memory {
load n; # max
dup; # max n
jump start; # max n
-
+
label loop; # max n
over 1; # max n max
over 1; # max in max n
@@ -3222,29 +3223,29 @@ test assemble-51.3 {memory leak testing} memory {
reverse 2; # n max
pop; # n
dup; # n n
-
+
label skip; # max n
dup; # max n n
push 2; # max n n 2
mod; # max n n%2
jumpTrue odd; # max n
-
+
push 2; # max n 2
div; # max n/2 -> max n
jump start; # max n
-
+
label odd; # max n
push 3; # max n 3
mult; # max 3*n
push 1; # max 3*n 1
add; # max 3*n+1
-
+
label start; # max n
dup; # max n n
push 1; # max n n 1
neq; # max n n>1
jumpTrue loop; # max n
-
+
pop; # max
}
}} 1
@@ -3277,7 +3278,7 @@ test assemble-52.1 {Bug 3154ea2759} {
label @okLabel
endCatch
pop
-
+
beginCatch @badLabel2
push error
push testing
@@ -3290,7 +3291,7 @@ test assemble-52.1 {Bug 3154ea2759} {
label @okLabel2
endCatch
pop
-
+
beginCatch @badLabel3
push error
push testing
@@ -3303,7 +3304,7 @@ test assemble-52.1 {Bug 3154ea2759} {
label @okLabel3
endCatch
pop
-
+
beginCatch @badLabel4
push error
push testing
@@ -3316,7 +3317,7 @@ test assemble-52.1 {Bug 3154ea2759} {
label @okLabel4
endCatch
pop
-
+
beginCatch @badLabel5
push error
push testing
@@ -3329,7 +3330,7 @@ test assemble-52.1 {Bug 3154ea2759} {
label @okLabel5
endCatch
pop
-
+
beginCatch @badLabel6
push error
push testing
diff --git a/tests/assemble1.bench b/tests/assemble1.bench
index 18fd3a9..e294108 100644
--- a/tests/assemble1.bench
+++ b/tests/assemble1.bench
@@ -20,7 +20,7 @@ proc ulam2 {n} {
load n; # max
dup; # max n
jump start; # max n
-
+
label loop; # max n
over 1; # max n max
over 1; # max in max n
@@ -30,29 +30,29 @@ proc ulam2 {n} {
reverse 2; # n max
pop; # n
dup; # n n
-
+
label skip; # max n
dup; # max n n
push 2; # max n n 2
mod; # max n n%2
jumpTrue odd; # max n
-
+
push 2; # max n 2
div; # max n/2 -> max n
jump start; # max n
-
+
label odd; # max n
push 3; # max n 3
mult; # max 3*n
push 1; # max 3*n 1
add; # max 3*n+1
-
+
label start; # max n
dup; # max n n
push 1; # max n n 1
neq; # max n n>1
jumpTrue loop; # max n
-
+
pop; # max
}
}
@@ -60,12 +60,12 @@ set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0
proc test1 {n} {
for {set i 1} {$i <= $n} {incr i} {
- ulam1 $i
+ ulam1 $i
}
}
proc test2 {n} {
for {set i 1} {$i <= $n} {incr i} {
- ulam2 $i
+ ulam2 $i
}
}
@@ -75,11 +75,10 @@ for {set j 0} {$j < 10} {incr j} {
test1 30000
set after [clock microseconds]
puts "compiled: [expr {1e-6 * ($after - $before)}]"
-
+
test2 1
set before [clock microseconds]
test2 30000
set after [clock microseconds]
puts "assembled: [expr {1e-6 * ($after - $before)}]"
}
- \ No newline at end of file
diff --git a/tests/async.test b/tests/async.test
index 4e7eadf..df13f83 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -20,7 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testasync [llength [info commands testasync]]
-testConstraint threaded [::tcl::pkgconfig get threaded]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
proc async1 {result code} {
@@ -150,7 +149,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
} -setup {
set hm [testasync create async3]
proc nothing {} {
@@ -179,7 +178,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
} -setup {
set hm [testasync create async3]
} -body {
@@ -204,7 +203,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 knownMsvcBug
+ testasync knownMsvcBug
} -setup {
set hm [testasync create async3]
} -body {
diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test
index 4721553..b42d50d 100644
--- a/tests/autoMkindex.test
+++ b/tests/autoMkindex.test
@@ -180,7 +180,7 @@ test autoMkindex-3.1 {slaveHook} -setup {
} -cleanup {
# Reset initCommands to avoid trashing other tests
AutoMkindexTestReset
-} -result 1
+} -result 1
# The auto_mkindex_parser::command is used to register commands that create
# new commands.
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
diff --git a/tests/basic.test b/tests/basic.test
index 5066877..428fd93 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -256,7 +256,7 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali
}
list [test_ns_basic::p] \
[rename test_ns_basic::p test_ns_basic::q] \
- [test_ns_basic::q]
+ [test_ns_basic::q]
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
@@ -469,11 +469,11 @@ test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
# a - the pure-list internal rep is destroyed by shimmering
# b - the command returns an error
# As the error code in Tcl_EvalObjv accesses the list elements, this will
- # cause a segfault if [Bug 1119369] has not been fixed.
+ # cause a segfault if [Bug 1119369] has not been fixed.
# NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
#
- set SRC [list foo 1] ;# pure-list command
+ set SRC [list foo 1] ;# pure-list command
proc foo str {
# Shimmer pure-list to cmdName, cleanup and error
proc $::SRC {} {}; $::SRC
@@ -491,11 +491,11 @@ test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
# Follow the pure-list branch in a manner that
# a - the pure-list internal rep is destroyed by shimmering
# b - the command accesses its command line
- # This will cause a segfault if [Bug 1119369] has not been fixed.
+ # This will cause a segfault if [Bug 1119369] has not been fixed.
# NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
#
- set SRC [list foo 1] ;# pure-list command
+ set SRC [list foo 1] ;# pure-list command
proc foo str {
# Shimmer pure-list to cmdName, cleanup and error
proc $::SRC {} {}; $::SRC
@@ -607,7 +607,7 @@ test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
invoked "break" outside of a loop
while executing
"break"
- (file "*BREAKtest" line 3)}
+ (file "*BREAKtest" line 3)}
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
@@ -624,7 +624,7 @@ test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing
"break"
- (file "*BREAKtest" line 4)}
+ (file "*BREAKtest" line 4)}
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
@@ -670,7 +670,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
@@ -752,7 +752,7 @@ test basic-48.1.$noComp {expansion: parsing} $constraints {
# Another comment
list 1 2\
3 {*}$::l1
-
+
# Comment again
}
} {1 2 3 a {b b} c d}
@@ -825,7 +825,7 @@ test basic-48.13.$noComp {expansion: odd usage} $constraints {
test basic-48.14.$noComp {expansion: hash command} -setup {
catch {rename \# ""}
set cmd "#"
- } -constraints $constraints -body {
+ } -constraints $constraints -body {
run { {*}$cmd apa bepa }
} -cleanup {
unset cmd
@@ -885,7 +885,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup {
stress
set tmp $end
set end [getbytes]
- }
+ }
set leak [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
@@ -893,21 +893,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 c2c5eb4..b06afe0 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -16,6 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
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 {} {
@@ -1647,22 +1648,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
@@ -1684,6 +1669,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
@@ -2501,9 +2511,9 @@ test binary-71.6 {binary decode hex} -body {
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
@@ -2665,11 +2675,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
@@ -2846,11 +2856,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
@@ -2878,7 +2888,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
@@ -2902,6 +2912,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,7 +2942,19 @@ test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat \u0141 B C] 1
} A
-
+test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
+ testbytestring "\u4E4E"
+} -result "expected byte sequence but character 0 was '\u4E4E' (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 '\u4E4E' (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 '\u4E4E' (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 6d63cea..d7558a9 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -11,6 +11,11 @@
# 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 {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
diff --git a/tests/chan.test b/tests/chan.test
index d8390e2..6808453 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -135,7 +135,7 @@ test chan-16.4 {chan command: pending subcommand} -body {
chan pending {input output} stdout
} -returnCodes error -result "bad mode \"input output\": must be input or output"
test chan-16.5 {chan command: pending input subcommand} -body {
- chan pending input stdout
+ chan pending input stdout
} -result -1
test chan-16.6 {chan command: pending input subcommand} -body {
chan pending input stdin
@@ -194,7 +194,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup {
set ::chan-16.9-data [list]
set ::chan-16.9-done 0
} -body {
- after idle chan-16.9-client
+ after idle chan-16.9-client
vwait ::chan-16.9-done
set ::chan-16.9-data
} -result {-1 0 0 1 36 -1 0 0 1 72 -1 0 0 1 108 -1 0 0 1 144 ABC 890} -cleanup {
diff --git a/tests/chanio.test b/tests/chanio.test
index 558ec10..a0a2130 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -889,7 +889,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
@@ -1130,7 +1130,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
@@ -5342,7 +5342,7 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
lappend x [chan gets $f]
} -cleanup {
chan close $f
-} -result {0600 {line 1}}
+} -result {0o600 {line 1}}
test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -constraints {unix umask} -body {
@@ -5350,7 +5350,7 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
chan close [open $path(test3) {WRONLY CREAT}]
file stat $path(test3) stats
format "%#o" [expr $stats(mode)&0o777]
-} -result [format %#4o [expr {0o666 & ~ $umaskValue}]]
+} -result [format %#5o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
diff --git a/tests/clock.test b/tests/clock.test
index 9c59b03..f9db14b 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -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:
@@ -35474,7 +35470,7 @@ test clock-33.5 {clock clicks tests, millisecond timing test} {
# 60 msecs seems to be the max time slice under Windows 95/98
expr {
($end > $start) && (($end - $start) <= 60) ?
- "ok" :
+ "ok" :
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.5a {clock tests, millisecond timing test} {
@@ -35490,7 +35486,7 @@ test clock-33.5a {clock tests, millisecond timing test} {
# 60 msecs seems to be the max time slice under Windows 95/98
expr {
($end > $start) && (($end - $start) <= 60) ?
- "ok" :
+ "ok" :
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index f19e11a..992a8f4 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -239,7 +239,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
} -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, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
file exists
} -result {wrong # args: should be "file exists name"}
@@ -1570,7 +1570,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, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, 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 *}
@@ -1702,6 +1702,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 0bf34a2..fe72d94 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -21,7 +21,7 @@ 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"}
@@ -149,12 +149,24 @@ 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 \0 \x7f \x80 \uffff]
+} [list \0 \x7f \x80 \uffff]
+test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii -nocase [list \0 \x7f \x80 \uffff]
+} [list \0 \x7f \x80 \uffff]
+test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
+} [list \0 \x7f \x80 \uffff \U01ffff]
+test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
+} [list \0 \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}
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
@@ -216,13 +228,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 +243,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 +269,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"}
@@ -776,6 +791,52 @@ test cmdIL-7.8 {lreverse command - shared intrep [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 +845,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/cmdMZ.test b/tests/cmdMZ.test
index 0f42f2f..43b3703 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -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
@@ -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 {
@@ -321,7 +317,7 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
-# todo: rewrite this if monotonic clock is provided resp. command "after"
+# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
set usec [expr {$msec * 1000}]
@@ -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 bae26a0..e57f799 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -20,12 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::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
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -84,8 +78,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
@@ -337,16 +331,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
@@ -602,22 +589,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: too few 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}
set a(VALUE) ff15
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 14c875d..3b44af8 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -16,12 +16,6 @@ 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
-}
-
# 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, too few arguments} -body {
expr {atan2(1.0)}
} -returnCodes error -match glob -result {too few arguments for math function*}
diff --git a/tests/compile.test b/tests/compile.test
index cb41063..18e978f 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -122,7 +122,7 @@ test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} {
proc foo {} {
set fail [catch {
return 1
- }] ; # {}
+ }] ; # {}
return 2
}
foo
@@ -132,8 +132,8 @@ test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} {
catch {
if {[a]} {
if b {}
- }
- }
+ }
+ }
}
list [catch foo msg] $msg
} {0 1}
@@ -344,13 +344,13 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
list [catch {p} msg] $msg
} -returnCodes error -result {unmatched open brace in list}
-#
+#
# Special section for tests of tclLiteral.c
# The following tests check for incorrect memory handling in
# TclReleaseLiteral. They are only effective when tcl is compiled with
# TCL_MEM_DEBUG
#
-# Special test for leak on interp delete [Bug 467523].
+# Special test for leak on interp delete [Bug 467523].
test compile-12.1 {testing literal leak on interp delete} -setup {
proc getbytes {} {
set lines [split [memory info] "\n"]
@@ -359,10 +359,10 @@ test compile-12.1 {testing literal leak on interp delete} -setup {
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
- interp create foo
- foo eval {
+ interp create foo
+ foo eval {
namespace eval bar {}
- }
+ }
interp delete foo
set tmp $end
set end [getbytes]
@@ -383,7 +383,7 @@ test compile-12.2 {testing error on literal deletion} -constraints {memory exec}
}
puts 0
} source.file]
- exec [interpreter] $sourceFile
+ exec [interpreter] $sourceFile
} -cleanup {
catch {removeFile $sourceFile}
} -result 0
@@ -508,7 +508,7 @@ test compile-13.3 {TclCompileScript: testing check of max depth by nested script
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
- # with 500 nested scripts (bodies). It must generate "too many nested compilations"
+ # with 500 nested scripts (bodies). It must generate "too many nested compilations"
# error for any variant we're testing here:
ti eval {foreach cmd {eval "if 1" try catch} {
set c [gencode 500 $cmd]
@@ -516,7 +516,7 @@ test compile-13.3 {TclCompileScript: testing check of max depth by nested script
}}
#puts $errors
# all of nested calls exceed the limit, so must end with "too many nested compilations"
- # (or evaluations, depending on compile method/instruction and "mixed" compile within
+ # (or evaluations, depending on compile method/instruction and "mixed" compile within
# evaliation), so no one succeeds, the result must be empty:
ti eval {set result}
} -result {}
@@ -537,7 +537,7 @@ test compile-14.1 {testing errors in element name; segfault?} {} {
test compile-14.2 {testing element name "$"} -body {
unset -nocomplain a
set a() 1
- set a(1) 2
+ set a(1) 2
set a($) 3
list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0]
} -cleanup {unset a} -result [list 1 2 3 {$}]
@@ -560,7 +560,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
diff --git a/tests/config.test b/tests/config.test
index d14837e..468a1df 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
test pkgconfig-1.1 {query keys} {
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}
+} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,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 df545f5..86a5481 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -66,7 +66,7 @@ test coroutine-1.3 {yield returns new arg} -setup {
incr i
}
}
- coroutine foo ::apply [list {{start 2} {stop 10}} $body]
+ coroutine foo ::apply [list {{start 2} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
@@ -476,7 +476,7 @@ test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels}
expr {[lindex [testnrelevels] 1] - 1}
}
proc relativeLevel base {
- # remove the level for this proc's call
+ # remove the level for this proc's call
expr {[getNumLevel] - $base - 1}
}
proc foo {} {
@@ -517,7 +517,7 @@ test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \
expr {[lindex [testnrelevels] 1] - 1}
}
proc relativeLevel base {
- # remove the level for this proc's call
+ # remove the level for this proc's call
expr {[getNumLevel] - $base - 1}
}
proc foo base {
@@ -588,7 +588,7 @@ test coroutine-7.2 {multi-argument yielding with yieldto} -body {
coroutine a corobody
coroutine b corobody
list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \
- [b ok] [rename b {}]
+ [b ok] [rename b {}]
} -cleanup {
rename corobody {}
} -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}}
@@ -793,7 +793,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 +948,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/dict.test b/tests/dict.test
index a6b0cb4..e5284fc 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -10,7 +10,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -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/encoding.test b/tests/encoding.test
index 935bef8..f483160 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -36,10 +36,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
@@ -306,18 +304,11 @@ test encoding-12.5 {LoadTableEncoding: symbol encoding} {
append x [encoding convertto symbol \u67]
append x [encoding convertfrom symbol \x67]
} "\x67\x67\u3b3"
-test encoding-12.6 {LoadTableEncoding: overflow in char value} ucs2 {
- encoding convertto iso8859-3 \U010000
-} "?"
test encoding-13.1 {LoadEscapeTable} {
viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
-test encoding-14.1 {BinaryProc} {
- encoding convertto identity \x12\x34\x56\xff\x69
-} "\x12\x34\x56\xc3\xbf\x69"
-
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 \xa3
} "\xc2\xa3"
@@ -334,12 +325,12 @@ 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 \U1F602"
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 \U1F602"
test encoding-15.6 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83D\uDE02\uD83D
set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D]
@@ -405,29 +396,46 @@ test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set y [encoding convertfrom 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 \U1F602
+ set y [encoding convertto utf-8 \U1F602]
+ binary scan $y H* z
+ list [string length $y] $z
+} {4 f09f9882}
-test encoding-16.1 {UnicodeToUtfProc} {
- set val [encoding convertfrom unicode NN]
+test encoding-16.1 {Utf16ToUtfProc} -body {
+ set val [encoding convertfrom utf-16 NN]
list $val [format %x [scan $val %c]]
-} "\u4e4e 4e4e"
-test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
- set val [encoding convertfrom unicode "\xD8\xD8\xDC\xDC"]
+} -result "\u4E4E 4e4e"
+test encoding-16.2 {Utf16ToUtfProc} -body {
+ set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
-test encoding-16.3 {UnicodeToUtfProc} -body {
- set val [encoding convertfrom unicode "\xDC\xDC"]
+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 "\u4E4E 4e4e"
+test encoding-16.4 {Ucs2ToUtfProc} -body {
+ set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"]
+ list $val [format %x [scan $val %c]]
+} -result "\U460DC 460dc"
-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 {UtfToUtf16Proc} -body {
+ encoding convertto utf-16 "\uDCDC"
} -result "\xDC\xDC"
-test encoding-17.3 {UtfToUnicodeProc} -body {
- encoding convertto unicode "\uD8D8"
+test encoding-17.3 {UtfToUtf16Proc} -body {
+ encoding convertto utf-16 "\uD8D8"
} -result "\xD8\xD8"
+test encoding-17.4 {UtfToUcs2Proc} -body {
+ encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"]
+} -result "\uFFFD"
test encoding-18.1 {TableToUtfProc} {
} {}
@@ -688,15 +696,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,7 +735,7 @@ test encoding-28.0 {all encodings load} -body {
llength $name
}
return $count
-} -result 81
+} -result [expr {[info exists ::tcl_precision] ? 86 : 85}]
runtests
diff --git a/tests/env.test b/tests/env.test
index 8eb5612..4af46c3 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -16,6 +16,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# [exec] is required here to see the actual environment received by child
@@ -419,8 +421,8 @@ test env-8.0 {
# cleanup
-rename getenv {}
-rename envrestore {}
+rename getenv {}
+rename envrestore {}
rename envprep {}
rename encodingrestore {}
rename encodingswitch {}
diff --git a/tests/event.test b/tests/event.test
index 67a980b..5c111f8 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -595,16 +595,16 @@ test event-11.7 {Bug 16828b3744} {
test event-11.8 {Bug 16828b3744} -setup {
oo::class create A {
variable continue
-
+
method start {} {
after idle [self] destroy
-
+
set continue 0
vwait [namespace current]::continue
}
destructor {
set continue 1
- }
+ }
}
} -body {
[A new] start
diff --git a/tests/exec.test b/tests/exec.test
index 62133e8..36aeae5 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -17,6 +17,8 @@
package require tcltest 2
namespace import -force ::tcltest::*
+loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# All tests require the "exec" command.
@@ -705,9 +707,6 @@ test exec-20.1 {exec .CMD file} -constraints {win} -body {
exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1"
viewFile $log
} -result "\"Testing exec-20.1\""
-
-
-
# ----------------------------------------------------------------------
# cleanup
diff --git a/tests/execute.test b/tests/execute.test
index 468901d..fbc4f99 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -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]]
@@ -703,7 +703,7 @@ test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
lappend result [e $e]
interp delete slave
interp create slave
- interp alias {} e slave expr
+ interp alias {} e slave expr
lappend result [e $e]
} -cleanup {
interp delete slave
@@ -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
@@ -1086,8 +1086,8 @@ test execute-10.3 {Bug 3072640} -setup {
yield $i
}
}
- proc t {args} {
- incr ::foo
+ proc t {args} {
+ incr ::foo
}
set ::foo 0
trace add execution ::generate enterstep ::t
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 06a00ba..003ee00 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -22,13 +22,8 @@ catch [list package require -exact Tcltest [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]
@@ -420,13 +415,13 @@ test expr-old-21.3 {parenthesization} {expr +(3-4)} -1
# Embedded commands and variable names.
-set a 16
-test expr-old-22.1 {embedded variables} {expr {2*$a}} 32
+set a 16
+test expr-old-22.1 {embedded variables} {expr {2*$a}} 32
test expr-old-22.2 {embedded variables} {
set x -5
set y 10
expr {$x + $y}
-} {5}
+} {5}
test expr-old-22.3 {embedded variables} {
set x " -5"
set y " +10"
@@ -819,10 +814,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 +842,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,11 +941,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
} -returnCodes error -match glob -result {*invalid octal number*}
@@ -1052,8 +1036,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 +1061,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 \
@@ -1120,7 +1108,7 @@ test expr-old-37.25 {Tcl_ExprDouble and NaN} \
{ieeeFloatingPoint testexprdouble} {
list [catch {testexprdouble 0.0/0.0} result] $result
} {1 {domain error: argument not in valid range}}
-
+
test expr-old-38.1 {Verify Tcl_ExprString's basic operation} -constraints {testexprstring} -body {
list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
[catch {testexprstring "1+"} msg] $msg
@@ -1159,8 +1147,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 {too few arguments to math function "min"}}
+ expr {min()}
+} -returnCodes error -result {too few 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 +1158,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 +1172,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 {too few arguments to math function "max"}}
+ expr {max()}
+} -returnCodes error -result {too few 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 +1183,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 0e3bd61..f0b75f4 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -18,17 +18,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::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"})
-}]
-
# 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]
@@ -138,7 +133,7 @@ proc do_twelve_days {} {
unset xxx
return $result
}
-
+
# start of tests
catch {unset a b i x}
@@ -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 *
@@ -685,41 +697,6 @@ test expr-15.5 {CompileMathFuncCall: too few 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 {" "}
} { }
@@ -1438,14 +1415,14 @@ test expr-23.74.3 {INST_EXPON: Bug 2798543} {
expr {(-14)**17 == (-14)**65553}
} 0
-
+
# Some compilers get this wrong; ensure that we work around it correctly
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
@@ -5786,7 +5763,7 @@ test expr-32.1 {expr mod basics} {
0 1 0 3 3 \
0 -1 0 -1 -2 \
]
-
+
test expr-32.2 {expr div basics} {
set mod_nums [list \
{-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \
@@ -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}
@@ -6759,8 +6736,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 \
@@ -6785,8 +6762,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 \
@@ -6794,7 +6771,7 @@ test expr-39.16 {Tcl_ExprLongObj handles overflows} \
list [catch {testexprlongobj 4294967296.} result] $result
} \
-result {1 {integer value too large to represent*}}
-
+
test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj {
testexprdoubleobj 4.+1.
} {This is a result: 5.0}
@@ -6881,19 +6858,19 @@ test expr-41.13 {exponent overflow} {
} 0.0
test expr-41.14 {exponent overflow} {
expr 100e-2147483651
-} 0.0
+} 0.0
test expr-41.15 {exponent overflow} {
expr 1.0e-2147483648
-} 0.0
+} 0.0
test expr-41.16 {exponent overflow} {
expr 1.0e-2147483649
-} 0.0
+} 0.0
test expr-41.17 {exponent overflow} {
expr 1.23e-2147483646
} 0.0
test expr-41.18 {exponent overflow} {
expr 1.23e-2147483647
-} 0.0
+} 0.0
test expr-41.19 {numSigDigs == 0} {
expr 0e309
@@ -7269,16 +7246,149 @@ test expr-52.1 {
list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [
string match {*no string representation*} [
::tcl::unsupported::representation $a]]
-} {0 0 1 1}
+} {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 "too few 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
-# cleanup
-if {[info exists a]} {
- unset a
+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 {too few arguments for math function "isunordered"}
+test expr-60.2 {float classification: basic arg handling} -body {
+ expr isunordered(1)
+} -returnCodes error -result {too few 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}]
+ }
}
-catch {unset min}
-catch {unset max}
+unset -nocomplain values results ctr
+
+# cleanup
+unset -nocomplain a
+unset -nocomplain min
+unset -nocomplain max
::tcltest::cleanupTests
return
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 260fde9..e8ed6f9 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -23,7 +23,7 @@ cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
-testConstraint win2000orXP 0
+testConstraint winXP 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
testConstraint reg 0
@@ -65,12 +65,10 @@ if {[testConstraint unix]} {
# Also used in winFCmd...
if {[testConstraint win]} {
- if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} {
- if {$::tcl_platform(osVersion) >= 6.0} {
- testConstraint winVista 1
- } else {
- testConstraint win2000orXP 1
- }
+ if {$::tcl_platform(osVersion) >= 5.0} {
+ testConstraint winVista 1
+ } else {
+ testConstraint winXP 1
}
}
@@ -791,7 +789,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup {
} -result {{tf3 tf4} 1 0}
test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
cleanup
-} -constraints {win win2000orXP testchmod} -body {
+} -constraints {win winXP testchmod} -body {
file mkdir td1 td2
testchmod 0o555 td2
file rename td1 td3
@@ -823,7 +821,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
} -result {tf1 tf2 1 0}
test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup {
cleanup
-} -constraints {win win2000orXP testchmod} -body {
+} -constraints {win winXP testchmod} -body {
file mkdir td1
file mkdir td2
testchmod 0o555 td2
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index d9264ee..361542d 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -147,7 +147,7 @@ test filesystem-1.10 {link normalisation: double link} -constraints {
[file normalize [file join dir2.link inside.file foo]]
} -cleanup {
file delete dir2.link
-} -result ok
+} -result ok
makeDirectory dir2.file
test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
file link dir2.link dir.link
@@ -907,7 +907,7 @@ test filesystem-9.5 {path objects and file tail and object rep} -setup {
}
return $res
} -cleanup {
- file delete -force dgp
+ file delete -force dgp
cd $origdir
} -result {test test}
test filesystem-9.6 {path objects and file tail and object rep} win {
diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test
index da301ce..0f8a2a7 100644
--- a/tests/fileSystemEncoding.test
+++ b/tests/fileSystemEncoding.test
@@ -39,7 +39,7 @@ namespace eval ::tcl::test::fileSystemEncoding {
set globbed [lindex [glob -directory $dir *] 0]
encoding system utf-8
set res [file exists $globbed]
- encoding system iso8859-1
+ encoding system iso8859-1
lappend res [file exists $globbed]
return $res
} -cleanup {
diff --git a/tests/for.test b/tests/for.test
index 1a65274..c8a8187 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -303,35 +303,35 @@ proc formatMail {} {
16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \
17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \
18 {releases were released on August 30, 1996. These releases contain only minor changes,} \
- 19 {so we hope to have only a single beta release and to go final in early October, 1996. } \
+ 19 {so we hope to have only a single beta release and to go final in early October, 1996.} \
20 {} \
21 {} \
- 22 {What's new } \
+ 22 {What's new} \
23 {} \
24 {The most important changes in the releases are summarized below. See the README} \
25 {and changes files in the distributions for more complete information on what has} \
- 26 {changed, including both feature changes and bug fixes. } \
+ 26 {changed, including both feature changes and bug fixes.} \
27 {} \
28 { There are new options to the file command for copying files (file copy),} \
29 { deleting files and directories (file delete), creating directories (file} \
- 30 { mkdir), and renaming files (file rename). } \
+ 30 { mkdir), and renaming files (file rename).} \
31 { The implementation of exec has been improved greatly for Windows 95 and} \
- 32 { Windows NT. } \
+ 32 { Windows NT.} \
33 { There is a new memory allocator for the Macintosh version, which should be} \
- 34 { more efficient than the old one. } \
+ 34 { more efficient than the old one.} \
35 { Tk's grid geometry manager has been completely rewritten. The layout} \
36 { algorithm produces much better layouts than before, especially where rows or} \
- 37 { columns were stretchable. } \
+ 37 { columns were stretchable.} \
38 { There are new commands for creating common dialog boxes:} \
39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \
- 40 { tk_messageBox. These use native dialog boxes if they are available. } \
+ 40 { tk_messageBox. These use native dialog boxes if they are available.} \
41 { There is a new virtual event mechanism for handling events in a more portable} \
42 { way. See the new command event. It also allows events (both physical and} \
- 43 { virtual) to be generated dynamically. } \
+ 43 { virtual) to be generated dynamically.} \
44 {} \
45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \
46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \
- 47 {should work on these new releases as well. } \
+ 47 {should work on these new releases as well.} \
48 {} \
49 {Obtaining The Releases} \
50 {} \
@@ -342,7 +342,7 @@ proc formatMail {} {
55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \
56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \
57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \
- 58 { tclsh programs, and documentation. } \
+ 58 { tclsh programs, and documentation.} \
59 { Macintosh (both 68K and PowerPC): Fetch} \
60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \
61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \
@@ -451,7 +451,7 @@ proc formatMail {} {
set c [string length $line]
}
}
- set newline [string range $line 0 $c]
+ set newline [string trimright [string range $line 0 $c]]
if {! $continuation} {
append result $newline $NL
} else {
@@ -507,76 +507,76 @@ releases of the Tcl scripting language and the Tk toolk
it. The first beta versions of these
releases were released on August 30, 1996. These releas
es contain only minor changes,
-so we hope to have only a single beta release and to
+so we hope to have only a single beta release and to
go final in early October, 1996.
-What's new
+What's new
The most important changes in the releases are summariz
ed below. See the README
and changes files in the distributions for more complet
e information on what has
-changed, including both feature changes and bug fixes.
+changed, including both feature changes and bug fixes.
- There are new options to the file command for
+ There are new options to the file command for
copying files (file copy),
- deleting files and directories (file delete),
+ deleting files and directories (file delete),
creating directories (file
- mkdir), and renaming files (file rename).
+ mkdir), and renaming files (file rename).
The implementation of exec has been improved great
ly for Windows 95 and
- Windows NT.
- There is a new memory allocator for the Macintosh
+ Windows NT.
+ There is a new memory allocator for the Macintosh
version, which should be
- more efficient than the old one.
- Tk's grid geometry manager has been completely
+ more efficient than the old one.
+ Tk's grid geometry manager has been completely
rewritten. The layout
algorithm produces much better layouts than before
, especially where rows or
- columns were stretchable.
- There are new commands for creating common dialog
+ columns were stretchable.
+ There are new commands for creating common dialog
boxes:
tk_chooseColor, tk_getOpenFile, tk_getSaveFile and
- tk_messageBox. These use native dialog boxes if
+ tk_messageBox. These use native dialog boxes if
they are available.
There is a new virtual event mechanism for handlin
g events in a more portable
- way. See the new command event. It also allows
+ way. See the new command event. It also allows
events (both physical and
- virtual) to be generated dynamically.
+ virtual) to be generated dynamically.
-Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl
+Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl
7.5 and Tk 4.1 except for
changes in the C APIs for custom channel drivers. Scrip
ts written for earlier releases
-should work on these new releases as well.
+should work on these new releases as well.
Obtaining The Releases
Binary Releases
-Pre-compiled releases are available for the following
+Pre-compiled releases are available for the following
platforms:
Windows 3.1, Windows 95, and Windows NT: Fetch
- ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
+ ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
execute it. The file is a
- self-extracting executable. It will install the
+ self-extracting executable. It will install the
Tcl and Tk libraries, the wish and
- tclsh programs, and documentation.
+ tclsh programs, and documentation.
Macintosh (both 68K and PowerPC): Fetch
- ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx.
+ ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx.
The file is in binhex format,
- which is understood by Fetch, StuffIt, and many
+ which is understood by Fetch, StuffIt, and many
other Mac utilities. The
- unpacked file is a self-installing executable:
+ unpacked file is a self-installing executable:
double-click on it and it will create a
- folder containing all that you need to run Tcl
+ folder containing all that you need to run Tcl
and Tk.
- UNIX (Solaris 2.* and SunOS, other systems
+ UNIX (Solaris 2.* and SunOS, other systems
soon to follow). Easy to install
- binary packages are now for sale at the Sun Labs
+ binary packages are now for sale at the Sun Labs
Tcl/Tk Shop. Check it out!
}
diff --git a/tests/format.test b/tests/format.test
index c26bbe9..3640376 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -16,11 +16,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
# %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}]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
test format-1.1 {integer formatting} {
@@ -28,7 +27,7 @@ test format-1.1 {integer formatting} {
} { 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}
@@ -54,49 +53,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} {
@@ -369,9 +359,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
@@ -383,6 +373,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}
@@ -536,7 +546,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} {
@@ -550,7 +560,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}
@@ -569,7 +579,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 7aa06c1..7ab189c 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -20,8 +20,8 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
-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}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
@@ -45,14 +45,14 @@ test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} {
list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} {
- list [catch {testgetint 18446744073709551614} msg] $msg
-} {0 -2}
+ testgetint 18446744073709551614
+} {-2}
test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} {
- list [catch {testgetint +18446744073709551614} msg] $msg
-} {0 -2}
+ testgetint +18446744073709551614
+} {-2}
test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} {
- list [catch {testgetint -18446744073709551614} msg] $msg
-} {0 2}
+ list [catch {testgetint -18446744073709551614} msg] $msg $errorCode
+} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} {
list [catch {testgetint 44 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
@@ -64,7 +64,7 @@ test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} {
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} {
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
@@ -98,17 +98,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 " " 0_07 " " 0o_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 7 8 {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 3201ad7..9ff41f2 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -10,7 +10,7 @@
#
# 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
namespace import -force ::tcltest::*
diff --git a/tests/http.test b/tests/http.test
index 73fe10c..8eac3c3 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -43,7 +43,6 @@ if {$::tcl_platform(os) eq "Darwin"} {
set HOST [info hostname]
}
-set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
@@ -62,9 +61,8 @@ catch {package require Thread 2.7-}
if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
set httpthread [thread::create -preserved]
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]} {
@@ -76,17 +74,15 @@ 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
- } else {
- set port [lindex [fconfigure $listen -sockname] 2]
}
}
test http-1.1 {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]
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
@@ -101,10 +97,10 @@ 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}
+} {-accept */* -cookiejar {} -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 {
http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
@@ -674,6 +670,451 @@ test http-7.4 {http::formatQuery} -setup {
http::config -urlencoding $enc
} -result {%3F}
+package require tcl::idna 1.0
+
+test http-idna-1.1 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna
+} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
+test http-idna-1.2 {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 {IDNA package: basics} -body {
+ ::tcl::idna version
+} -result 1.0.1
+test http-idna-1.4 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna version what
+} -result {wrong # args: should be "::tcl::idna version"}
+test http-idna-1.5 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny
+} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
+test http-idna-1.6 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny ?
+} -result {unknown or ambiguous subcommand "?": must be decode, or encode}
+test http-idna-1.7 {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 {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 {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 {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 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna decode
+} -result {wrong # args: should be "::tcl::idna decode hostname"}
+test http-idna-1.12 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna encode
+} -result {wrong # args: should be "::tcl::idna encode hostname"}
+
+test http-idna-2.1 {puny encode: functional test} {
+ ::tcl::idna puny encode abc
+} abc-
+test http-idna-2.2 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20acb\u20acc
+} abc-k50ab
+test http-idna-2.3 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC
+} ABC-
+test http-idna-2.4 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC
+} ABC-k50ab
+test http-idna-2.5 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 0
+} abc-
+test http-idna-2.6 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC 0
+} abc-k50ab
+test http-idna-2.7 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 1
+} ABC-
+test http-idna-2.8 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC 1
+} ABC-k50ab
+test http-idna-2.9 {puny encode: functional test} {
+ ::tcl::idna puny encode abc 0
+} abc-
+test http-idna-2.10 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20ACb\u20ACc 0
+} abc-k50ab
+test http-idna-2.11 {puny encode: functional test} {
+ ::tcl::idna puny encode abc 1
+} ABC-
+test http-idna-2.12 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20ACb\u20ACc 1
+} ABC-k50ab
+test http-idna-2.13 {puny encode: edge cases} {
+ ::tcl::idna puny encode ""
+} ""
+test http-idna-2.14-A {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode {-> $1.00 <-}
+} {-> $1.00 <--}
+
+test http-idna-3.1 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-
+} abc
+test http-idna-3.2 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab
+} a\u20acb\u20acc
+test http-idna-3.3 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-
+} ABC
+test http-idna-3.4 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-k50ab
+} A\u20ACB\u20ACC
+test http-idna-3.5 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB
+} A\u20ACB\u20ACC
+test http-idna-3.6 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-K50AB
+} a\u20ACb\u20ACc
+test http-idna-3.7 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 0
+} abc
+test http-idna-3.8 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 0
+} a\u20ACb\u20ACc
+test http-idna-3.9 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 1
+} ABC
+test http-idna-3.10 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 1
+} A\u20ACB\u20ACC
+test http-idna-3.11 {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 0
+} abc
+test http-idna-3.12 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 0
+} a\u20ACb\u20ACc
+test http-idna-3.13 {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 1
+} ABC
+test http-idna-3.14 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 1
+} A\u20ACB\u20ACC
+test http-idna-3.15 {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 {puny decode: edge cases and errors} -returnCodes error -body {
+ ::tcl::idna puny decode abc!
+} -result {bad decode character "!"}
+test http-idna-3.17 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {puny decode: examples from RFC 3492} {
+ ::tcl::idna puny decode {-> $1.00 <--}
+} {-> $1.00 <-}
+rename hexify ""
+
+test http-idna-4.1 {IDNA encoding} {
+ ::tcl::idna encode abc.def
+} abc.def
+test http-idna-4.2 {IDNA encoding} {
+ ::tcl::idna encode a\u20acb\u20acc.def
+} xn--abc-k50ab.def
+test http-idna-4.3 {IDNA encoding} {
+ ::tcl::idna encode def.a\u20acb\u20acc
+} def.xn--abc-k50ab
+test http-idna-4.4 {IDNA encoding} {
+ ::tcl::idna encode ABC.DEF
+} ABC.DEF
+test http-idna-4.5 {IDNA encoding} {
+ ::tcl::idna encode A\u20acB\u20acC.def
+} xn--ABC-k50ab.def
+test http-idna-4.6 {IDNA encoding: invalid edge case} {
+ # Should this be an error?
+ ::tcl::idna encode abc..def
+} abc..def
+test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body {
+ ::tcl::idna encode abc.$.def
+} -result {bad character "$" in DNS name}
+test http-idna-4.7.1 {IDNA encoding: invalid char} {
+ catch {::tcl::idna encode abc.$.def} -> opt
+ dict get $opt -errorcode
+} {IDNA INVALID_NAME_CHARACTER {$}}
+test http-idna-4.8 {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 {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 {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 {IDNA encoding: edge cases} {
+ ::tcl::idna encode pass\u00e9.example.com
+} xn--pass-epa.example.com
+
+test http-idna-5.1 {IDNA decoding} {
+ ::tcl::idna decode abc.def
+} abc.def
+test http-idna-5.2 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.def
+} abc.def
+test http-idna-5.3 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.xn--def-
+} abc.def
+test http-idna-5.4 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode XN--abc-.XN--def-
+} abc.def
+test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--$$$.example.com
+} -result {bad decode character "$"}
+test http-idna-5.5.1 {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 {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def
+} -result {exceeded input data}
+test http-idna-5.6.1 {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}
diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl
index 326b361..4345845 100644
--- a/tests/httpTest.tcl
+++ b/tests/httpTest.tcl
@@ -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/httpcookie.test b/tests/httpcookie.test
new file mode 100644
index 0000000..b3c5412
--- /dev/null
+++ b/tests/httpcookie.test
@@ -0,0 +1,876 @@
+# 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 (c) 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.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+::tcltest::loadTestedCommands
+
+testConstraint notOSXtravis [apply {{} {
+ upvar 1 env(TRAVIS_OSX_IMAGE) travis
+ return [expr {![info exists travis] || ![string match xcode* $travis]}]
+}}]
+testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![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 16e0382..982f3b8 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -18,7 +18,12 @@ if {$::tcl_platform(os) eq "Darwin"} {
}
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
@@ -216,7 +221,7 @@ proc httpdRespond { sock } {
}
# Catch errors from premature client closes
-
+
catch {
if {$data(proto) == "HEAD"} {
puts $sock "HTTP/1.0 200 OK"
diff --git a/tests/httpold.test b/tests/httpold.test
deleted file mode 100644
index e63bcda..0000000
--- a/tests/httpold.test
+++ /dev/null
@@ -1,300 +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 {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- 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 slave 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
- }
-}
-
-if {$::tcl_platform(os) eq "Darwin"} {
- # Name resolution often a problem on OSX; not focus of HTTP package anyway
- set HOST localhost
-} else {
- set HOST [info hostname]
-}
-
-set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
-catch {unset data}
-
-##
-## The httpd script implement a stub http server
-##
-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} {
- update
- set x {}
- after 500 {lappend x ok}
- set token [http_get $url -timeout 1 -command {lappend x fail}]
- vwait x
- list [http_status $token] $x
-} {timeout ok}
-
-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/incr.test b/tests/incr.test
index 9243be0..aa2872a 100644
--- a/tests/incr.test
+++ b/tests/incr.test
@@ -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 646cb02..126d062 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -109,7 +109,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\""
diff --git a/tests/info.test b/tests/info.test
index 5fe2240..ce51523 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -19,9 +19,9 @@ if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
-
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [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
@@ -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 {} {}
@@ -2099,7 +2099,7 @@ proc foo::bar {} {
foreach {*}{
x y
{set res [info frame 0]}
- }
+ }
return $res
}
test info-33.13 {{*}, literal, simple, bytecompiled} -body {
@@ -2114,7 +2114,7 @@ proc foo::bar {} {
if {*}{
{[return [info frame 0]]}
{}
- }
+ }
}
test info-33.14 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
@@ -2128,7 +2128,7 @@ proc foo::bar {} {
if 0 {*}{
{} else
{return [info frame 0]}
- }
+ }
}
test info-33.15 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
@@ -2229,7 +2229,7 @@ namespace eval foo {}
proc foo::bar {} {
try {*}{
{set res [info frame 0]}
- }
+ }
return $res
}
test info-33.23 {{*}, literal, simple, bytecompiled} -body {
@@ -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: slaves} -setup {
+ apply {i {
+ rename $i ::testinfocmdtype::slave
+ variable ::testinfocmdtype::slave $i
+ }} [interp create]
+} -body {
+ info cmdtype ::testinfocmdtype::slave
+} -cleanup {
+ interp delete $::testinfocmdtype::slave
+} -result slave
+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 slave 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 slave 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 slave 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 slave 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 1d838ef..a241c0b 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -41,7 +41,7 @@ test init-1.2 {auto_qualify - absolute cmd - global} {
} global
test init-1.3 {auto_qualify - no colons cmd - global} {
auto_qualify nocolons ::
-} nocolons
+} nocolons
test init-1.4 {auto_qualify - no colons cmd - namespace} {
auto_qualify nocolons ::sub
} {::sub::nocolons nocolons}
@@ -106,11 +106,11 @@ test init-2.5 {load safe:::setLogCmd - stage 2} {
auto_reset
catch {rename ::safe::setLogCmd {}}
test init-2.6 {load setLogCmd from safe:: - stage 1} {
- namespace eval safe setLogCmd
+ namespace eval safe setLogCmd
rename ::safe::setLogCmd {} ;# should not fail
} {}
test init-2.7 {oad setLogCmd from safe:: - stage 2} {
- namespace eval safe setLogCmd
+ namespace eval safe setLogCmd
rename ::safe::setLogCmd {} ;# should not fail
} {}
test init-2.8 {load tcl::HistAdd} -setup {
@@ -145,12 +145,12 @@ foreach arg [subst -nocommands -novariables {
and is long enough to be truncated and
" <- includes a false lead in the prune point search
and must be longer still to force truncation}
- {contrived example: rare circumstance
+ {contrived example: rare circumstance
where the point at which to prune the
error stack cannot be uniquely determined.
foo bar foo
"}
- {contrived example: rare circumstance
+ {contrived example: rare circumstance
where the point at which to prune the
error stack cannot be uniquely determined.
foo bar
diff --git a/tests/internals.tcl b/tests/internals.tcl
index 6b5bb87..e859afe 100644
--- a/tests/internals.tcl
+++ b/tests/internals.tcl
@@ -21,7 +21,7 @@ namespace path ::tcltest
# Options:
# -addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test)
# -maxmem - set absolute maximum address space limit (in bytes)
-#
+#
proc testWithLimit args {
set body [lindex $args end]
array set in [lrange $args 0 end-1]
@@ -45,7 +45,7 @@ proc testWithLimit args {
incr in(-addmem) 20000000
# + size of locale-archive (may be up to 100MB):
incr in(-addmem) [expr {
- [file exists /usr/lib/locale/locale-archive] ?
+ [file exists /usr/lib/locale/locale-archive] ?
[file size /usr/lib/locale/locale-archive] : 0
}]
}
diff --git a/tests/interp.test b/tests/interp.test
index 5b7b157..599ac08 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
-set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl: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 slaves] {
interp delete $i
@@ -56,7 +56,7 @@ test interp-1.8 {options for interp command} -returnCodes error -body {
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, 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, 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, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, 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"}
@@ -70,7 +70,7 @@ test interp-2.2 {basic interpreter creation} {
} 0
test interp-2.3 {basic interpreter creation} {
catch {interp create -safe}
-} 0
+} 0
test interp-2.4 {basic interpreter creation} -setup {
catch {interp create a}
} -returnCodes error -body {
@@ -106,7 +106,7 @@ test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum > $thenum
-} 1
+} 1
test interp-2.12 {anonymous interps vs existing procs} {
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy thenum
@@ -876,12 +876,12 @@ test interp-18.9 {eval in deleted interp, bug 495830} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {suicide; set a 5}} msg] $msg
-} {1 {attempt to call eval in deleted interpreter}}
+} {1 {attempt to call eval in deleted interpreter}}
test interp-18.10 {eval in deleted interp, bug 495830} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg
-} {1 {attempt to call eval in deleted interpreter}}
+} {1 {attempt to call eval in deleted interpreter}}
# Test alias deletion
@@ -971,7 +971,7 @@ test interp-19.9 {alias deletion, renaming} {
set l [interp eval a foo]
interp delete a
set l
-} 1156
+} 1156
test interp-20.1 {interp hide, interp expose and interp invokehidden} {
set a [interp create]
@@ -1192,7 +1192,7 @@ test interp-20.21 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {a hide list} msg]
+ lappend l [catch {a hide list} msg]
lappend l $msg
interp delete a
set l
@@ -1201,7 +1201,7 @@ test interp-20.22 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {interp hide a list} msg]
+ lappend l [catch {interp hide a list} msg]
lappend l $msg
interp delete a
set l
@@ -1210,7 +1210,7 @@ test interp-20.23 {interp hide vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {a eval {interp hide {} list}} msg]
+ lappend l [catch {a eval {interp hide {} list}} msg]
lappend l $msg
interp delete a
set l
@@ -1220,7 +1220,7 @@ test interp-20.24 {interp hide vs safety} {
interp create a -safe
interp create {a b}
set l ""
- lappend l [catch {a eval {interp hide b list}} msg]
+ lappend l [catch {a eval {interp hide b list}} msg]
lappend l $msg
interp delete a
set l
@@ -1239,7 +1239,7 @@ test interp-20.26 {interp expoose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {a hide list} msg]
+ lappend l [catch {a hide list} msg]
lappend l $msg
lappend l [catch {a expose list} msg]
lappend l $msg
@@ -1250,9 +1250,9 @@ test interp-20.27 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {interp hide a list} msg]
+ lappend l [catch {interp hide a list} msg]
lappend l $msg
- lappend l [catch {interp expose a list} msg]
+ lappend l [catch {interp expose a list} msg]
lappend l $msg
interp delete a
set l
@@ -1261,7 +1261,7 @@ test interp-20.28 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {a hide list} msg]
+ lappend l [catch {a hide list} msg]
lappend l $msg
lappend l [catch {a eval {interp expose {} list}} msg]
lappend l $msg
@@ -1272,9 +1272,9 @@ test interp-20.29 {interp expose vs safety} {
catch {interp delete a}
interp create a -safe
set l ""
- lappend l [catch {interp hide a list} msg]
+ lappend l [catch {interp hide a list} msg]
lappend l $msg
- lappend l [catch {a eval {interp expose {} list}} msg]
+ lappend l [catch {a eval {interp expose {} list}} msg]
lappend l $msg
interp delete a
set l
@@ -1284,9 +1284,9 @@ test interp-20.30 {interp expose vs safety} {
interp create a -safe
interp create {a b}
set l ""
- lappend l [catch {interp hide {a b} list} msg]
+ lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
- lappend l [catch {a eval {interp expose b list}} msg]
+ lappend l [catch {a eval {interp expose b list}} msg]
lappend l $msg
interp delete a
set l
@@ -1296,7 +1296,7 @@ test interp-20.31 {interp expose vs safety} {
interp create a -safe
interp create {a b}
set l ""
- lappend l [catch {interp hide {a b} list} msg]
+ lappend l [catch {interp hide {a b} list} msg]
lappend l $msg
lappend l [catch {interp expose {a b} list} msg]
lappend l $msg
@@ -1676,7 +1676,7 @@ test interp-21.5 {interp hidden} -setup {
lsort [interp hidden a]
} -cleanup {
interp delete a
-} -result $hidden_cmds
+} -result $hidden_cmds
test interp-21.6 {interp hidden vs interp hide, interp expose} -setup {
catch {interp delete a}
set l ""
@@ -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}
@@ -2200,7 +2200,7 @@ test interp-27.1 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
set aliasTrace {}
- proc tstAlias {args} {
+ proc tstAlias {args} {
global aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
@@ -2214,7 +2214,7 @@ test interp-27.2 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
set aliasTrace {}
- proc tstAlias {args} {
+ proc tstAlias {args} {
global aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
@@ -2228,7 +2228,7 @@ test interp-27.3 {interp aliases & namespaces} -setup {
set i [interp create]
} -body {
set aliasTrace {}
- proc tstAlias {args} {
+ proc tstAlias {args} {
global aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
@@ -2244,7 +2244,7 @@ test interp-27.4 {interp aliases & namespaces} -setup {
} -body {
namespace eval foo2 {
variable aliasTrace {}
- proc bar {args} {
+ proc bar {args} {
variable aliasTrace
lappend aliasTrace [list [namespace current] $args]
}
@@ -3321,7 +3321,7 @@ test interp-34.9 {time limits trigger in blocking after} {
} msg]
set t1 [clock seconds]
interp delete $i
- list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}]
+ list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}]
} {1 {time limit exceeded} OK}
test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body {
set i [interp create]
@@ -3555,7 +3555,7 @@ test interp-35.24 {interp time limits can't touch current interp} -body {
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
-test interp-36.2 {interp bgerror syntax} -body {
+test interp-36.2 {interp bgerror syntax} -body {
interp bgerror x y z
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.3 {interp bgerror syntax} -setup {
diff --git a/tests/io.test b/tests/io.test
index 458cc5d..592f09f 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -123,10 +123,10 @@ test io-1.8 {Tcl_WriteChars: WriteChars} {
# applied to tcl will cause tcl, more specifically WriteChars, to
# go into an infinite loop.
- set f [open $path(test2) w]
- fconfigure $f -encoding iso2022-jp
- puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
- close $f
+ set f [open $path(test2) w]
+ fconfigure $f -encoding iso2022-jp
+ puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
+ close $f
contents $path(test2)
} " \x1b\$B\$O\x1b(B"
@@ -192,7 +192,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} {
test io-2.1 {WriteBytes} {
# loop until all bytes are written
-
+
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
@@ -214,7 +214,7 @@ test io-2.3 {WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
-
+
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation crlf
puts -nonewline $f "\n12"
@@ -234,7 +234,7 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} {
test io-3.1 {WriteChars: compatibility with WriteBytes} {
# loop until all bytes are written
-
+
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
@@ -256,7 +256,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
-
+
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation crlf
puts -nonewline $f "\n12"
@@ -268,7 +268,7 @@ test io-3.4 {WriteChars: loop over stage buffer} {
# 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
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
@@ -280,7 +280,7 @@ test io-3.5 {WriteChars: saved != 0} {
# requested buffersize.
set f [open $path(test1) w]
- fconfigure $f -encoding jis0208 -buffersize 17
+ fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
@@ -311,7 +311,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
# of the next channel buffer.
set f [open $path(test1) w]
- fconfigure $f -encoding jis0208 -buffersize 17
+ fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
@@ -381,7 +381,7 @@ test io-4.5 {TranslateOutputEOL: crlf} {
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
- fconfigure $f
+ fconfigure $f
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
@@ -470,7 +470,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
test io-6.6 {Tcl_GetsObj: loop test} {
- # if (dst >= dstEnd)
+ # if (dst >= dstEnd)
set f [open $path(test1) w]
puts $f $a
@@ -769,7 +769,7 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel}
} [list 15 "123456789012345" 17 3]
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
# eol still equals dstEnd
-
+
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
@@ -781,8 +781,8 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
set x
} [list 16 "123456789012345\r" 1]
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
- # not (*eol == '\n')
-
+ # not (*eol == '\n')
+
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\rabcd\r\nefg"
@@ -889,7 +889,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent}
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
- lappend x [gets $f line] $line [testchannel queuedcr $f]
+ lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
@@ -898,7 +898,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent}
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} {
- # not (*eol == '\n')
+ # not (*eol == '\n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
@@ -906,7 +906,7 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
- lappend x [gets $f line] $line [testchannel queuedcr $f]
+ lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "abcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
@@ -919,7 +919,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
@@ -959,10 +959,10 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha
set x [list [gets $f] [testchannel inputbuffered $f]]
close $f
set x
-} [list "123456789012345" 15]
+} [list "123456789012345" 15]
test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
# PeekAhead() did not get any, so (eol >= dstEnd)
-
+
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
@@ -975,7 +975,7 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc
} [list "123456789012345" 1]
test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
# if (*eol == '\n') {skip++}
-
+
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r\n78901"
@@ -986,8 +986,8 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
set x
} [list "123456" 0 8 "78901"]
test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
- # not (*eol == '\n')
-
+ # not (*eol == '\n')
+
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r78901"
@@ -999,7 +999,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
} [list "123456" 0 7 "78901"]
test io-6.51 {Tcl_GetsObj: auto mode: \n} {
# else if (*eol == '\n') {goto gotoeol;}
-
+
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\n78901"
@@ -1092,7 +1092,7 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} {
} "1234567890123\uff10\uff11\uff12\uff13\uff14"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
-
+
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
@@ -1163,7 +1163,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
@@ -1201,7 +1201,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} {
set x [gets $f]
close $f
- set x
+ set x
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} {
@@ -1217,7 +1217,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op
set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} {
- # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
+ # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
@@ -1574,7 +1574,7 @@ test io-13.2 {TranslateInputEOL: crlf mode} {
set x
} "abcd\ndef\n"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
- # (src >= srcMax)
+ # (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
@@ -1587,7 +1587,7 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
set x
} "abcd\ndef\r"
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
- # (src >= srcMax)
+ # (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
@@ -1600,7 +1600,7 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
set x
} "abcd\ndef\rfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
- # (src >= srcMax)
+ # (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
@@ -1715,7 +1715,7 @@ test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
set x
} "abcd\ndef"
test io-13.10 {TranslateInputEOL: auto mode: \n} {
- # not (*src == '\r')
+ # not (*src == '\r')
set f [open $path(test1) w]
fconfigure $f -translation lf
@@ -2064,7 +2064,7 @@ test io-20.1 {Tcl_CreateChannel: initial settings} {
encoding system $old
close $a
set x
-} {ascii}
+} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {win} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
@@ -2159,7 +2159,7 @@ test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} {
set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
-} {}
+} {}
# Test flushing. The functions tested here are FlushChannel.
@@ -3057,7 +3057,7 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
fconfigure $f -translation crlf
set x [read $f]
close $f
- set x
+ set x
} "hello\rthere\rand\rhere\r"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
file delete $path(test1)
@@ -3985,7 +3985,7 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
}
close $f
set f [open $path(test1) r]
- fconfigure $f -translation crlf
+ fconfigure $f -translation crlf
set c ""
while {[gets $f line] >= 0} {
append c $line\n
@@ -5474,7 +5474,7 @@ test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -encoding {}
+ fconfigure $f -encoding {}
puts -nonewline $f \xe7\x89\xa6
close $f
set f [open $path(test1) r]
@@ -5637,7 +5637,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} {
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]
@@ -5652,7 +5652,7 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
close $f
file stat $path(test3) stats
format "%#o" [expr $stats(mode)&0o777]
-} [format %#4o [expr {0o666 & ~ $umaskValue}]]
+} [format %#5o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
@@ -5964,6 +5964,70 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi
} {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} {
@@ -8651,11 +8715,11 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup {
interp create slave
} -constraints testobj -body {
teststringobj set 1 [string range $rfd 0 end]
- read [teststringobj get 1]
+ read [teststringobj get 1]
testobj duplicate 1 2
interp transfer {} $rfd slave
catch {read [teststringobj get 1]}
- read [teststringobj get 2]
+ read [teststringobj get 2]
} -cleanup {
interp delete slave
testobj freeallvars
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 5c45630..0e47d2f 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -14,7 +14,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -154,10 +154,10 @@ test iocmd-4.11 {read command} {
test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
} -body {
- list [catch {read $f 12z} msg] $msg $::errorCode
+ read $f 12z
} -cleanup {
close $f
-} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
+} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
@@ -206,78 +206,90 @@ 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 -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
+ fconfigure $f1
+} -cleanup {
+ catch {close $f1}
+} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -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
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 {} -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"}}
+ fconfigure $f1
+} -cleanup {
+ catch {close $f1}
+} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -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
@@ -294,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr
close $srv
unset cli srv port
rename iocmdSRV {}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname}
+} -returnCodes error -result [expectedOpts "-blah" {-connecting -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]
@@ -337,7 +349,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl
if {$tty ne ""} {
close $tty
}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}
+} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}]
test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup {
set tty ""
} -body {
@@ -348,7 +360,13 @@ 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).
@@ -912,6 +930,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.
@@ -1984,28 +2013,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 }
@@ -2018,6 +2048,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
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 85e427a..0a335ff 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -1320,7 +1320,7 @@ proc inthread {chan script args} {
# forwarded channel operations.
set ::tres ""
- thread::send -async $tid {
+ thread::send -async $tid {
after 50
catch {s} res; # This runs the script, 's' was defined at (*)
thread::send -async $mid [list set ::tres $res]
diff --git a/tests/iogt.test b/tests/iogt.test
index 269a0ba..3cac2cf 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -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.
-#
+#
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
diff --git a/tests/lindex.test b/tests/lindex.test
index e513b62..2b1742e 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -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,80 +385,69 @@ 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
catch { unset minus }
diff --git a/tests/link.test b/tests/link.test
index 189762e..336634b 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -20,6 +20,7 @@ if {"::tcltest" ni [namespace children]} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
+testConstraint testlinkarray [llength [info commands testlinkarray]]
foreach i {int real bool string} {
unset -nocomplain $i
@@ -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/lmap.test b/tests/lmap.test
index 08035d9..641eac2 100644
--- a/tests/lmap.test
+++ b/tests/lmap.test
@@ -220,10 +220,10 @@ test lmap-4.14 {lmap errors} -returnCodes error -body {
} -result {list element in braces followed by "3" instead of space}
unset -nocomplain a
test lmap-4.15 {lmap errors} {
- apply {{} {
+ apply {{} {
set a(0) 44
- list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo
- }}
+ list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo
+ }}
} {1 {can't set "a": variable is array} {can't set "a": variable is array
while executing
"lmap a {1 2 3} {}"}}
diff --git a/tests/lpop.test b/tests/lpop.test
new file mode 100644
index 0000000..3e28978
--- /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 (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994 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 {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ 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 d5676ad..5798707 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -20,7 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
-
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
@@ -69,7 +68,7 @@ test lrange-1.15 {range of list elements} {
} {"a b \{\ "}
# emacs highlighting bug workaround --> "
test lrange-1.16 {list element quoting} {
- lrange {[append a .b]} 0 end
+ lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
@@ -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 788bb9b..e89f1b7 100644
--- a/tests/lrepeat.test
+++ b/tests/lrepeat.test
@@ -40,7 +40,7 @@ test lrepeat-1.4 {error cases} {
lrepeat -3 1
}
-returnCodes 1
- -result {bad count "-3": must be integer >= 0}
+ -result {bad count "-3": must be integer >= 0}
}
test lrepeat-1.5 {Accept zero repetitions (TIP 323)} {
-body {
@@ -53,7 +53,7 @@ test lrepeat-1.6 {error cases} {
lrepeat 3.5 1
}
-returnCodes 1
- -result {expected integer but got "3.5"}
+ -result {expected integer but got "3.5"}
}
test lrepeat-1.7 {Accept zero repetitions (TIP 323)} {
-body {
diff --git a/tests/lreplace.test b/tests/lreplace.test
index fd2f7f8..4ce3ef4 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -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,8 @@ 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
}
}
}
diff --git a/tests/lsearch.test b/tests/lsearch.test
index 7e6a345..2086615 100644
--- a/tests/lsearch.test
+++ b/tests/lsearch.test
@@ -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}
@@ -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,149 @@ 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 -result {stride length must be at least 1}
+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
+
# cleanup
catch {unset res}
diff --git a/tests/lset.test b/tests/lset.test
index 1c1300b..b1ed110 100644
--- a/tests/lset.test
+++ b/tests/lset.test
@@ -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 6846cbf..32bfd5f 100644
--- a/tests/lsetComp.test
+++ b/tests/lsetComp.test
@@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
proc evalInProc { script } {
proc testProc {} $script
set status [catch {
- testProc
+ testProc
} result]
rename testProc {}
return [list $status $result]
@@ -60,69 +60,69 @@ test lsetComp-2.3 {lset, compiled, list of args, scalar, one-byte offset} {
test lsetComp-2.4 {lset, compiled, list of args, scalar, four-byte offset} {
evalInProc {
- set x0 0; set x1 0; set x2 0; set x3 0;
- set x4 0; set x5 0; set x6 0; set x7 0;
- set x8 0; set x9 0; set x10 0; set x11 0;
- set x12 0; set x13 0; set x14 0; set x15 0;
- set x16 0; set x17 0; set x18 0; set x19 0;
- set x20 0; set x21 0; set x22 0; set x23 0;
- set x24 0; set x25 0; set x26 0; set x27 0;
- set x28 0; set x29 0; set x30 0; set x31 0;
- set x32 0; set x33 0; set x34 0; set x35 0;
- set x36 0; set x37 0; set x38 0; set x39 0;
- set x40 0; set x41 0; set x42 0; set x43 0;
- set x44 0; set x45 0; set x46 0; set x47 0;
- set x48 0; set x49 0; set x50 0; set x51 0;
- set x52 0; set x53 0; set x54 0; set x55 0;
- set x56 0; set x57 0; set x58 0; set x59 0;
- set x60 0; set x61 0; set x62 0; set x63 0;
- set x64 0; set x65 0; set x66 0; set x67 0;
- set x68 0; set x69 0; set x70 0; set x71 0;
- set x72 0; set x73 0; set x74 0; set x75 0;
- set x76 0; set x77 0; set x78 0; set x79 0;
- set x80 0; set x81 0; set x82 0; set x83 0;
- set x84 0; set x85 0; set x86 0; set x87 0;
- set x88 0; set x89 0; set x90 0; set x91 0;
- set x92 0; set x93 0; set x94 0; set x95 0;
- set x96 0; set x97 0; set x98 0; set x99 0;
- set x100 0; set x101 0; set x102 0; set x103 0;
- set x104 0; set x105 0; set x106 0; set x107 0;
- set x108 0; set x109 0; set x110 0; set x111 0;
- set x112 0; set x113 0; set x114 0; set x115 0;
- set x116 0; set x117 0; set x118 0; set x119 0;
- set x120 0; set x121 0; set x122 0; set x123 0;
- set x124 0; set x125 0; set x126 0; set x127 0;
- set x128 0; set x129 0; set x130 0; set x131 0;
- set x132 0; set x133 0; set x134 0; set x135 0;
- set x136 0; set x137 0; set x138 0; set x139 0;
- set x140 0; set x141 0; set x142 0; set x143 0;
- set x144 0; set x145 0; set x146 0; set x147 0;
- set x148 0; set x149 0; set x150 0; set x151 0;
- set x152 0; set x153 0; set x154 0; set x155 0;
- set x156 0; set x157 0; set x158 0; set x159 0;
- set x160 0; set x161 0; set x162 0; set x163 0;
- set x164 0; set x165 0; set x166 0; set x167 0;
- set x168 0; set x169 0; set x170 0; set x171 0;
- set x172 0; set x173 0; set x174 0; set x175 0;
- set x176 0; set x177 0; set x178 0; set x179 0;
- set x180 0; set x181 0; set x182 0; set x183 0;
- set x184 0; set x185 0; set x186 0; set x187 0;
- set x188 0; set x189 0; set x190 0; set x191 0;
- set x192 0; set x193 0; set x194 0; set x195 0;
- set x196 0; set x197 0; set x198 0; set x199 0;
- set x200 0; set x201 0; set x202 0; set x203 0;
- set x204 0; set x205 0; set x206 0; set x207 0;
- set x208 0; set x209 0; set x210 0; set x211 0;
- set x212 0; set x213 0; set x214 0; set x215 0;
- set x216 0; set x217 0; set x218 0; set x219 0;
- set x220 0; set x221 0; set x222 0; set x223 0;
- set x224 0; set x225 0; set x226 0; set x227 0;
- set x228 0; set x229 0; set x230 0; set x231 0;
- set x232 0; set x233 0; set x234 0; set x235 0;
- set x236 0; set x237 0; set x238 0; set x239 0;
- set x240 0; set x241 0; set x242 0; set x243 0;
- set x244 0; set x245 0; set x246 0; set x247 0;
- set x248 0; set x249 0; set x250 0; set x251 0;
+ set x0 0; set x1 0; set x2 0; set x3 0;
+ set x4 0; set x5 0; set x6 0; set x7 0;
+ set x8 0; set x9 0; set x10 0; set x11 0;
+ set x12 0; set x13 0; set x14 0; set x15 0;
+ set x16 0; set x17 0; set x18 0; set x19 0;
+ set x20 0; set x21 0; set x22 0; set x23 0;
+ set x24 0; set x25 0; set x26 0; set x27 0;
+ set x28 0; set x29 0; set x30 0; set x31 0;
+ set x32 0; set x33 0; set x34 0; set x35 0;
+ set x36 0; set x37 0; set x38 0; set x39 0;
+ set x40 0; set x41 0; set x42 0; set x43 0;
+ set x44 0; set x45 0; set x46 0; set x47 0;
+ set x48 0; set x49 0; set x50 0; set x51 0;
+ set x52 0; set x53 0; set x54 0; set x55 0;
+ set x56 0; set x57 0; set x58 0; set x59 0;
+ set x60 0; set x61 0; set x62 0; set x63 0;
+ set x64 0; set x65 0; set x66 0; set x67 0;
+ set x68 0; set x69 0; set x70 0; set x71 0;
+ set x72 0; set x73 0; set x74 0; set x75 0;
+ set x76 0; set x77 0; set x78 0; set x79 0;
+ set x80 0; set x81 0; set x82 0; set x83 0;
+ set x84 0; set x85 0; set x86 0; set x87 0;
+ set x88 0; set x89 0; set x90 0; set x91 0;
+ set x92 0; set x93 0; set x94 0; set x95 0;
+ set x96 0; set x97 0; set x98 0; set x99 0;
+ set x100 0; set x101 0; set x102 0; set x103 0;
+ set x104 0; set x105 0; set x106 0; set x107 0;
+ set x108 0; set x109 0; set x110 0; set x111 0;
+ set x112 0; set x113 0; set x114 0; set x115 0;
+ set x116 0; set x117 0; set x118 0; set x119 0;
+ set x120 0; set x121 0; set x122 0; set x123 0;
+ set x124 0; set x125 0; set x126 0; set x127 0;
+ set x128 0; set x129 0; set x130 0; set x131 0;
+ set x132 0; set x133 0; set x134 0; set x135 0;
+ set x136 0; set x137 0; set x138 0; set x139 0;
+ set x140 0; set x141 0; set x142 0; set x143 0;
+ set x144 0; set x145 0; set x146 0; set x147 0;
+ set x148 0; set x149 0; set x150 0; set x151 0;
+ set x152 0; set x153 0; set x154 0; set x155 0;
+ set x156 0; set x157 0; set x158 0; set x159 0;
+ set x160 0; set x161 0; set x162 0; set x163 0;
+ set x164 0; set x165 0; set x166 0; set x167 0;
+ set x168 0; set x169 0; set x170 0; set x171 0;
+ set x172 0; set x173 0; set x174 0; set x175 0;
+ set x176 0; set x177 0; set x178 0; set x179 0;
+ set x180 0; set x181 0; set x182 0; set x183 0;
+ set x184 0; set x185 0; set x186 0; set x187 0;
+ set x188 0; set x189 0; set x190 0; set x191 0;
+ set x192 0; set x193 0; set x194 0; set x195 0;
+ set x196 0; set x197 0; set x198 0; set x199 0;
+ set x200 0; set x201 0; set x202 0; set x203 0;
+ set x204 0; set x205 0; set x206 0; set x207 0;
+ set x208 0; set x209 0; set x210 0; set x211 0;
+ set x212 0; set x213 0; set x214 0; set x215 0;
+ set x216 0; set x217 0; set x218 0; set x219 0;
+ set x220 0; set x221 0; set x222 0; set x223 0;
+ set x224 0; set x225 0; set x226 0; set x227 0;
+ set x228 0; set x229 0; set x230 0; set x231 0;
+ set x232 0; set x233 0; set x234 0; set x235 0;
+ set x236 0; set x237 0; set x238 0; set x239 0;
+ set x240 0; set x241 0; set x242 0; set x243 0;
+ set x244 0; set x245 0; set x246 0; set x247 0;
+ set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set x {{1 2} {3 4}}
lset x {1 1} 5
@@ -145,69 +145,69 @@ test lsetComp-2.6 {lset, compiled, list of args, array, one-byte offset} {
test lsetComp-2.7 {lset, compiled, list of args, array, four-byte offset} {
evalInProc {
- set x0 0; set x1 0; set x2 0; set x3 0;
- set x4 0; set x5 0; set x6 0; set x7 0;
- set x8 0; set x9 0; set x10 0; set x11 0;
- set x12 0; set x13 0; set x14 0; set x15 0;
- set x16 0; set x17 0; set x18 0; set x19 0;
- set x20 0; set x21 0; set x22 0; set x23 0;
- set x24 0; set x25 0; set x26 0; set x27 0;
- set x28 0; set x29 0; set x30 0; set x31 0;
- set x32 0; set x33 0; set x34 0; set x35 0;
- set x36 0; set x37 0; set x38 0; set x39 0;
- set x40 0; set x41 0; set x42 0; set x43 0;
- set x44 0; set x45 0; set x46 0; set x47 0;
- set x48 0; set x49 0; set x50 0; set x51 0;
- set x52 0; set x53 0; set x54 0; set x55 0;
- set x56 0; set x57 0; set x58 0; set x59 0;
- set x60 0; set x61 0; set x62 0; set x63 0;
- set x64 0; set x65 0; set x66 0; set x67 0;
- set x68 0; set x69 0; set x70 0; set x71 0;
- set x72 0; set x73 0; set x74 0; set x75 0;
- set x76 0; set x77 0; set x78 0; set x79 0;
- set x80 0; set x81 0; set x82 0; set x83 0;
- set x84 0; set x85 0; set x86 0; set x87 0;
- set x88 0; set x89 0; set x90 0; set x91 0;
- set x92 0; set x93 0; set x94 0; set x95 0;
- set x96 0; set x97 0; set x98 0; set x99 0;
- set x100 0; set x101 0; set x102 0; set x103 0;
- set x104 0; set x105 0; set x106 0; set x107 0;
- set x108 0; set x109 0; set x110 0; set x111 0;
- set x112 0; set x113 0; set x114 0; set x115 0;
- set x116 0; set x117 0; set x118 0; set x119 0;
- set x120 0; set x121 0; set x122 0; set x123 0;
- set x124 0; set x125 0; set x126 0; set x127 0;
- set x128 0; set x129 0; set x130 0; set x131 0;
- set x132 0; set x133 0; set x134 0; set x135 0;
- set x136 0; set x137 0; set x138 0; set x139 0;
- set x140 0; set x141 0; set x142 0; set x143 0;
- set x144 0; set x145 0; set x146 0; set x147 0;
- set x148 0; set x149 0; set x150 0; set x151 0;
- set x152 0; set x153 0; set x154 0; set x155 0;
- set x156 0; set x157 0; set x158 0; set x159 0;
- set x160 0; set x161 0; set x162 0; set x163 0;
- set x164 0; set x165 0; set x166 0; set x167 0;
- set x168 0; set x169 0; set x170 0; set x171 0;
- set x172 0; set x173 0; set x174 0; set x175 0;
- set x176 0; set x177 0; set x178 0; set x179 0;
- set x180 0; set x181 0; set x182 0; set x183 0;
- set x184 0; set x185 0; set x186 0; set x187 0;
- set x188 0; set x189 0; set x190 0; set x191 0;
- set x192 0; set x193 0; set x194 0; set x195 0;
- set x196 0; set x197 0; set x198 0; set x199 0;
- set x200 0; set x201 0; set x202 0; set x203 0;
- set x204 0; set x205 0; set x206 0; set x207 0;
- set x208 0; set x209 0; set x210 0; set x211 0;
- set x212 0; set x213 0; set x214 0; set x215 0;
- set x216 0; set x217 0; set x218 0; set x219 0;
- set x220 0; set x221 0; set x222 0; set x223 0;
- set x224 0; set x225 0; set x226 0; set x227 0;
- set x228 0; set x229 0; set x230 0; set x231 0;
- set x232 0; set x233 0; set x234 0; set x235 0;
- set x236 0; set x237 0; set x238 0; set x239 0;
- set x240 0; set x241 0; set x242 0; set x243 0;
- set x244 0; set x245 0; set x246 0; set x247 0;
- set x248 0; set x249 0; set x250 0; set x251 0;
+ set x0 0; set x1 0; set x2 0; set x3 0;
+ set x4 0; set x5 0; set x6 0; set x7 0;
+ set x8 0; set x9 0; set x10 0; set x11 0;
+ set x12 0; set x13 0; set x14 0; set x15 0;
+ set x16 0; set x17 0; set x18 0; set x19 0;
+ set x20 0; set x21 0; set x22 0; set x23 0;
+ set x24 0; set x25 0; set x26 0; set x27 0;
+ set x28 0; set x29 0; set x30 0; set x31 0;
+ set x32 0; set x33 0; set x34 0; set x35 0;
+ set x36 0; set x37 0; set x38 0; set x39 0;
+ set x40 0; set x41 0; set x42 0; set x43 0;
+ set x44 0; set x45 0; set x46 0; set x47 0;
+ set x48 0; set x49 0; set x50 0; set x51 0;
+ set x52 0; set x53 0; set x54 0; set x55 0;
+ set x56 0; set x57 0; set x58 0; set x59 0;
+ set x60 0; set x61 0; set x62 0; set x63 0;
+ set x64 0; set x65 0; set x66 0; set x67 0;
+ set x68 0; set x69 0; set x70 0; set x71 0;
+ set x72 0; set x73 0; set x74 0; set x75 0;
+ set x76 0; set x77 0; set x78 0; set x79 0;
+ set x80 0; set x81 0; set x82 0; set x83 0;
+ set x84 0; set x85 0; set x86 0; set x87 0;
+ set x88 0; set x89 0; set x90 0; set x91 0;
+ set x92 0; set x93 0; set x94 0; set x95 0;
+ set x96 0; set x97 0; set x98 0; set x99 0;
+ set x100 0; set x101 0; set x102 0; set x103 0;
+ set x104 0; set x105 0; set x106 0; set x107 0;
+ set x108 0; set x109 0; set x110 0; set x111 0;
+ set x112 0; set x113 0; set x114 0; set x115 0;
+ set x116 0; set x117 0; set x118 0; set x119 0;
+ set x120 0; set x121 0; set x122 0; set x123 0;
+ set x124 0; set x125 0; set x126 0; set x127 0;
+ set x128 0; set x129 0; set x130 0; set x131 0;
+ set x132 0; set x133 0; set x134 0; set x135 0;
+ set x136 0; set x137 0; set x138 0; set x139 0;
+ set x140 0; set x141 0; set x142 0; set x143 0;
+ set x144 0; set x145 0; set x146 0; set x147 0;
+ set x148 0; set x149 0; set x150 0; set x151 0;
+ set x152 0; set x153 0; set x154 0; set x155 0;
+ set x156 0; set x157 0; set x158 0; set x159 0;
+ set x160 0; set x161 0; set x162 0; set x163 0;
+ set x164 0; set x165 0; set x166 0; set x167 0;
+ set x168 0; set x169 0; set x170 0; set x171 0;
+ set x172 0; set x173 0; set x174 0; set x175 0;
+ set x176 0; set x177 0; set x178 0; set x179 0;
+ set x180 0; set x181 0; set x182 0; set x183 0;
+ set x184 0; set x185 0; set x186 0; set x187 0;
+ set x188 0; set x189 0; set x190 0; set x191 0;
+ set x192 0; set x193 0; set x194 0; set x195 0;
+ set x196 0; set x197 0; set x198 0; set x199 0;
+ set x200 0; set x201 0; set x202 0; set x203 0;
+ set x204 0; set x205 0; set x206 0; set x207 0;
+ set x208 0; set x209 0; set x210 0; set x211 0;
+ set x212 0; set x213 0; set x214 0; set x215 0;
+ set x216 0; set x217 0; set x218 0; set x219 0;
+ set x220 0; set x221 0; set x222 0; set x223 0;
+ set x224 0; set x225 0; set x226 0; set x227 0;
+ set x228 0; set x229 0; set x230 0; set x231 0;
+ set x232 0; set x233 0; set x234 0; set x235 0;
+ set x236 0; set x237 0; set x238 0; set x239 0;
+ set x240 0; set x241 0; set x242 0; set x243 0;
+ set x244 0; set x245 0; set x246 0; set x247 0;
+ set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set y(0) {{1 2} {3 4}}
lset y(0) {1 1} 5
@@ -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 } }
@@ -253,69 +253,69 @@ test lsetComp-3.3 {lset, compiled, flat args, scalar, one-byte offset} {
test lsetComp-3.4 {lset, compiled, scalar, four-byte offset} {
evalInProc {
- set x0 0; set x1 0; set x2 0; set x3 0;
- set x4 0; set x5 0; set x6 0; set x7 0;
- set x8 0; set x9 0; set x10 0; set x11 0;
- set x12 0; set x13 0; set x14 0; set x15 0;
- set x16 0; set x17 0; set x18 0; set x19 0;
- set x20 0; set x21 0; set x22 0; set x23 0;
- set x24 0; set x25 0; set x26 0; set x27 0;
- set x28 0; set x29 0; set x30 0; set x31 0;
- set x32 0; set x33 0; set x34 0; set x35 0;
- set x36 0; set x37 0; set x38 0; set x39 0;
- set x40 0; set x41 0; set x42 0; set x43 0;
- set x44 0; set x45 0; set x46 0; set x47 0;
- set x48 0; set x49 0; set x50 0; set x51 0;
- set x52 0; set x53 0; set x54 0; set x55 0;
- set x56 0; set x57 0; set x58 0; set x59 0;
- set x60 0; set x61 0; set x62 0; set x63 0;
- set x64 0; set x65 0; set x66 0; set x67 0;
- set x68 0; set x69 0; set x70 0; set x71 0;
- set x72 0; set x73 0; set x74 0; set x75 0;
- set x76 0; set x77 0; set x78 0; set x79 0;
- set x80 0; set x81 0; set x82 0; set x83 0;
- set x84 0; set x85 0; set x86 0; set x87 0;
- set x88 0; set x89 0; set x90 0; set x91 0;
- set x92 0; set x93 0; set x94 0; set x95 0;
- set x96 0; set x97 0; set x98 0; set x99 0;
- set x100 0; set x101 0; set x102 0; set x103 0;
- set x104 0; set x105 0; set x106 0; set x107 0;
- set x108 0; set x109 0; set x110 0; set x111 0;
- set x112 0; set x113 0; set x114 0; set x115 0;
- set x116 0; set x117 0; set x118 0; set x119 0;
- set x120 0; set x121 0; set x122 0; set x123 0;
- set x124 0; set x125 0; set x126 0; set x127 0;
- set x128 0; set x129 0; set x130 0; set x131 0;
- set x132 0; set x133 0; set x134 0; set x135 0;
- set x136 0; set x137 0; set x138 0; set x139 0;
- set x140 0; set x141 0; set x142 0; set x143 0;
- set x144 0; set x145 0; set x146 0; set x147 0;
- set x148 0; set x149 0; set x150 0; set x151 0;
- set x152 0; set x153 0; set x154 0; set x155 0;
- set x156 0; set x157 0; set x158 0; set x159 0;
- set x160 0; set x161 0; set x162 0; set x163 0;
- set x164 0; set x165 0; set x166 0; set x167 0;
- set x168 0; set x169 0; set x170 0; set x171 0;
- set x172 0; set x173 0; set x174 0; set x175 0;
- set x176 0; set x177 0; set x178 0; set x179 0;
- set x180 0; set x181 0; set x182 0; set x183 0;
- set x184 0; set x185 0; set x186 0; set x187 0;
- set x188 0; set x189 0; set x190 0; set x191 0;
- set x192 0; set x193 0; set x194 0; set x195 0;
- set x196 0; set x197 0; set x198 0; set x199 0;
- set x200 0; set x201 0; set x202 0; set x203 0;
- set x204 0; set x205 0; set x206 0; set x207 0;
- set x208 0; set x209 0; set x210 0; set x211 0;
- set x212 0; set x213 0; set x214 0; set x215 0;
- set x216 0; set x217 0; set x218 0; set x219 0;
- set x220 0; set x221 0; set x222 0; set x223 0;
- set x224 0; set x225 0; set x226 0; set x227 0;
- set x228 0; set x229 0; set x230 0; set x231 0;
- set x232 0; set x233 0; set x234 0; set x235 0;
- set x236 0; set x237 0; set x238 0; set x239 0;
- set x240 0; set x241 0; set x242 0; set x243 0;
- set x244 0; set x245 0; set x246 0; set x247 0;
- set x248 0; set x249 0; set x250 0; set x251 0;
+ set x0 0; set x1 0; set x2 0; set x3 0;
+ set x4 0; set x5 0; set x6 0; set x7 0;
+ set x8 0; set x9 0; set x10 0; set x11 0;
+ set x12 0; set x13 0; set x14 0; set x15 0;
+ set x16 0; set x17 0; set x18 0; set x19 0;
+ set x20 0; set x21 0; set x22 0; set x23 0;
+ set x24 0; set x25 0; set x26 0; set x27 0;
+ set x28 0; set x29 0; set x30 0; set x31 0;
+ set x32 0; set x33 0; set x34 0; set x35 0;
+ set x36 0; set x37 0; set x38 0; set x39 0;
+ set x40 0; set x41 0; set x42 0; set x43 0;
+ set x44 0; set x45 0; set x46 0; set x47 0;
+ set x48 0; set x49 0; set x50 0; set x51 0;
+ set x52 0; set x53 0; set x54 0; set x55 0;
+ set x56 0; set x57 0; set x58 0; set x59 0;
+ set x60 0; set x61 0; set x62 0; set x63 0;
+ set x64 0; set x65 0; set x66 0; set x67 0;
+ set x68 0; set x69 0; set x70 0; set x71 0;
+ set x72 0; set x73 0; set x74 0; set x75 0;
+ set x76 0; set x77 0; set x78 0; set x79 0;
+ set x80 0; set x81 0; set x82 0; set x83 0;
+ set x84 0; set x85 0; set x86 0; set x87 0;
+ set x88 0; set x89 0; set x90 0; set x91 0;
+ set x92 0; set x93 0; set x94 0; set x95 0;
+ set x96 0; set x97 0; set x98 0; set x99 0;
+ set x100 0; set x101 0; set x102 0; set x103 0;
+ set x104 0; set x105 0; set x106 0; set x107 0;
+ set x108 0; set x109 0; set x110 0; set x111 0;
+ set x112 0; set x113 0; set x114 0; set x115 0;
+ set x116 0; set x117 0; set x118 0; set x119 0;
+ set x120 0; set x121 0; set x122 0; set x123 0;
+ set x124 0; set x125 0; set x126 0; set x127 0;
+ set x128 0; set x129 0; set x130 0; set x131 0;
+ set x132 0; set x133 0; set x134 0; set x135 0;
+ set x136 0; set x137 0; set x138 0; set x139 0;
+ set x140 0; set x141 0; set x142 0; set x143 0;
+ set x144 0; set x145 0; set x146 0; set x147 0;
+ set x148 0; set x149 0; set x150 0; set x151 0;
+ set x152 0; set x153 0; set x154 0; set x155 0;
+ set x156 0; set x157 0; set x158 0; set x159 0;
+ set x160 0; set x161 0; set x162 0; set x163 0;
+ set x164 0; set x165 0; set x166 0; set x167 0;
+ set x168 0; set x169 0; set x170 0; set x171 0;
+ set x172 0; set x173 0; set x174 0; set x175 0;
+ set x176 0; set x177 0; set x178 0; set x179 0;
+ set x180 0; set x181 0; set x182 0; set x183 0;
+ set x184 0; set x185 0; set x186 0; set x187 0;
+ set x188 0; set x189 0; set x190 0; set x191 0;
+ set x192 0; set x193 0; set x194 0; set x195 0;
+ set x196 0; set x197 0; set x198 0; set x199 0;
+ set x200 0; set x201 0; set x202 0; set x203 0;
+ set x204 0; set x205 0; set x206 0; set x207 0;
+ set x208 0; set x209 0; set x210 0; set x211 0;
+ set x212 0; set x213 0; set x214 0; set x215 0;
+ set x216 0; set x217 0; set x218 0; set x219 0;
+ set x220 0; set x221 0; set x222 0; set x223 0;
+ set x224 0; set x225 0; set x226 0; set x227 0;
+ set x228 0; set x229 0; set x230 0; set x231 0;
+ set x232 0; set x233 0; set x234 0; set x235 0;
+ set x236 0; set x237 0; set x238 0; set x239 0;
+ set x240 0; set x241 0; set x242 0; set x243 0;
+ set x244 0; set x245 0; set x246 0; set x247 0;
+ set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set x {{1 2} {3 4}}
lset x 1 1 5
@@ -338,69 +338,69 @@ test lsetComp-3.6 {lset, compiled, flat args, array, one-byte offset} {
test lsetComp-3.7 {lset, compiled, flat args, array, four-byte offset} {
evalInProc {
- set x0 0; set x1 0; set x2 0; set x3 0;
- set x4 0; set x5 0; set x6 0; set x7 0;
- set x8 0; set x9 0; set x10 0; set x11 0;
- set x12 0; set x13 0; set x14 0; set x15 0;
- set x16 0; set x17 0; set x18 0; set x19 0;
- set x20 0; set x21 0; set x22 0; set x23 0;
- set x24 0; set x25 0; set x26 0; set x27 0;
- set x28 0; set x29 0; set x30 0; set x31 0;
- set x32 0; set x33 0; set x34 0; set x35 0;
- set x36 0; set x37 0; set x38 0; set x39 0;
- set x40 0; set x41 0; set x42 0; set x43 0;
- set x44 0; set x45 0; set x46 0; set x47 0;
- set x48 0; set x49 0; set x50 0; set x51 0;
- set x52 0; set x53 0; set x54 0; set x55 0;
- set x56 0; set x57 0; set x58 0; set x59 0;
- set x60 0; set x61 0; set x62 0; set x63 0;
- set x64 0; set x65 0; set x66 0; set x67 0;
- set x68 0; set x69 0; set x70 0; set x71 0;
- set x72 0; set x73 0; set x74 0; set x75 0;
- set x76 0; set x77 0; set x78 0; set x79 0;
- set x80 0; set x81 0; set x82 0; set x83 0;
- set x84 0; set x85 0; set x86 0; set x87 0;
- set x88 0; set x89 0; set x90 0; set x91 0;
- set x92 0; set x93 0; set x94 0; set x95 0;
- set x96 0; set x97 0; set x98 0; set x99 0;
- set x100 0; set x101 0; set x102 0; set x103 0;
- set x104 0; set x105 0; set x106 0; set x107 0;
- set x108 0; set x109 0; set x110 0; set x111 0;
- set x112 0; set x113 0; set x114 0; set x115 0;
- set x116 0; set x117 0; set x118 0; set x119 0;
- set x120 0; set x121 0; set x122 0; set x123 0;
- set x124 0; set x125 0; set x126 0; set x127 0;
- set x128 0; set x129 0; set x130 0; set x131 0;
- set x132 0; set x133 0; set x134 0; set x135 0;
- set x136 0; set x137 0; set x138 0; set x139 0;
- set x140 0; set x141 0; set x142 0; set x143 0;
- set x144 0; set x145 0; set x146 0; set x147 0;
- set x148 0; set x149 0; set x150 0; set x151 0;
- set x152 0; set x153 0; set x154 0; set x155 0;
- set x156 0; set x157 0; set x158 0; set x159 0;
- set x160 0; set x161 0; set x162 0; set x163 0;
- set x164 0; set x165 0; set x166 0; set x167 0;
- set x168 0; set x169 0; set x170 0; set x171 0;
- set x172 0; set x173 0; set x174 0; set x175 0;
- set x176 0; set x177 0; set x178 0; set x179 0;
- set x180 0; set x181 0; set x182 0; set x183 0;
- set x184 0; set x185 0; set x186 0; set x187 0;
- set x188 0; set x189 0; set x190 0; set x191 0;
- set x192 0; set x193 0; set x194 0; set x195 0;
- set x196 0; set x197 0; set x198 0; set x199 0;
- set x200 0; set x201 0; set x202 0; set x203 0;
- set x204 0; set x205 0; set x206 0; set x207 0;
- set x208 0; set x209 0; set x210 0; set x211 0;
- set x212 0; set x213 0; set x214 0; set x215 0;
- set x216 0; set x217 0; set x218 0; set x219 0;
- set x220 0; set x221 0; set x222 0; set x223 0;
- set x224 0; set x225 0; set x226 0; set x227 0;
- set x228 0; set x229 0; set x230 0; set x231 0;
- set x232 0; set x233 0; set x234 0; set x235 0;
- set x236 0; set x237 0; set x238 0; set x239 0;
- set x240 0; set x241 0; set x242 0; set x243 0;
- set x244 0; set x245 0; set x246 0; set x247 0;
- set x248 0; set x249 0; set x250 0; set x251 0;
+ set x0 0; set x1 0; set x2 0; set x3 0;
+ set x4 0; set x5 0; set x6 0; set x7 0;
+ set x8 0; set x9 0; set x10 0; set x11 0;
+ set x12 0; set x13 0; set x14 0; set x15 0;
+ set x16 0; set x17 0; set x18 0; set x19 0;
+ set x20 0; set x21 0; set x22 0; set x23 0;
+ set x24 0; set x25 0; set x26 0; set x27 0;
+ set x28 0; set x29 0; set x30 0; set x31 0;
+ set x32 0; set x33 0; set x34 0; set x35 0;
+ set x36 0; set x37 0; set x38 0; set x39 0;
+ set x40 0; set x41 0; set x42 0; set x43 0;
+ set x44 0; set x45 0; set x46 0; set x47 0;
+ set x48 0; set x49 0; set x50 0; set x51 0;
+ set x52 0; set x53 0; set x54 0; set x55 0;
+ set x56 0; set x57 0; set x58 0; set x59 0;
+ set x60 0; set x61 0; set x62 0; set x63 0;
+ set x64 0; set x65 0; set x66 0; set x67 0;
+ set x68 0; set x69 0; set x70 0; set x71 0;
+ set x72 0; set x73 0; set x74 0; set x75 0;
+ set x76 0; set x77 0; set x78 0; set x79 0;
+ set x80 0; set x81 0; set x82 0; set x83 0;
+ set x84 0; set x85 0; set x86 0; set x87 0;
+ set x88 0; set x89 0; set x90 0; set x91 0;
+ set x92 0; set x93 0; set x94 0; set x95 0;
+ set x96 0; set x97 0; set x98 0; set x99 0;
+ set x100 0; set x101 0; set x102 0; set x103 0;
+ set x104 0; set x105 0; set x106 0; set x107 0;
+ set x108 0; set x109 0; set x110 0; set x111 0;
+ set x112 0; set x113 0; set x114 0; set x115 0;
+ set x116 0; set x117 0; set x118 0; set x119 0;
+ set x120 0; set x121 0; set x122 0; set x123 0;
+ set x124 0; set x125 0; set x126 0; set x127 0;
+ set x128 0; set x129 0; set x130 0; set x131 0;
+ set x132 0; set x133 0; set x134 0; set x135 0;
+ set x136 0; set x137 0; set x138 0; set x139 0;
+ set x140 0; set x141 0; set x142 0; set x143 0;
+ set x144 0; set x145 0; set x146 0; set x147 0;
+ set x148 0; set x149 0; set x150 0; set x151 0;
+ set x152 0; set x153 0; set x154 0; set x155 0;
+ set x156 0; set x157 0; set x158 0; set x159 0;
+ set x160 0; set x161 0; set x162 0; set x163 0;
+ set x164 0; set x165 0; set x166 0; set x167 0;
+ set x168 0; set x169 0; set x170 0; set x171 0;
+ set x172 0; set x173 0; set x174 0; set x175 0;
+ set x176 0; set x177 0; set x178 0; set x179 0;
+ set x180 0; set x181 0; set x182 0; set x183 0;
+ set x184 0; set x185 0; set x186 0; set x187 0;
+ set x188 0; set x189 0; set x190 0; set x191 0;
+ set x192 0; set x193 0; set x194 0; set x195 0;
+ set x196 0; set x197 0; set x198 0; set x199 0;
+ set x200 0; set x201 0; set x202 0; set x203 0;
+ set x204 0; set x205 0; set x206 0; set x207 0;
+ set x208 0; set x209 0; set x210 0; set x211 0;
+ set x212 0; set x213 0; set x214 0; set x215 0;
+ set x216 0; set x217 0; set x218 0; set x219 0;
+ set x220 0; set x221 0; set x222 0; set x223 0;
+ set x224 0; set x225 0; set x226 0; set x227 0;
+ set x228 0; set x229 0; set x230 0; set x231 0;
+ set x232 0; set x233 0; set x234 0; set x235 0;
+ set x236 0; set x237 0; set x238 0; set x239 0;
+ set x240 0; set x241 0; set x242 0; set x243 0;
+ set x244 0; set x245 0; set x246 0; set x247 0;
+ set x248 0; set x249 0; set x250 0; set x251 0;
set x252 0; set x253 0; set x254 0; set x255 0;
set y(0) {{1 2} {3 4}}
lset y(0) 1 1 5
@@ -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/main.test b/tests/main.test
index c4bb48d..0398d36 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -16,7 +16,7 @@ namespace eval ::tcl::test::main {
# - tests use testing commands introduced in Tcltest 8.4
testConstraint Tcltest [expr {
[llength [package provide Tcltest]]
- && [package vsatisfies [package provide Tcltest] 8.4]}]
+ && [package vsatisfies [package provide Tcltest] 8.5-]}]
# Procedure to simulate interactive typing of commands, line by line
proc type {chan script} {
diff --git a/tests/mathop.test b/tests/mathop.test
index a1a3f80..958a56f 100644
--- a/tests/mathop.test
+++ b/tests/mathop.test
@@ -95,7 +95,7 @@ proc TestOp {op args} {
}
return [lindex $results 0]
}
-
+
# start of tests
namespace eval ::testmathop {
@@ -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 d4ece74..db8b14a 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -25,7 +25,7 @@ testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
test misc-1.1 {error in variable ref. in command in array reference} {
proc tstProc {} {
global a
-
+
set tst $a([winfo name $zz])
# this is a bogus comment
# this is a bogus comment
@@ -42,7 +42,7 @@ test misc-1.1 {error in variable ref. in command in array reference} {
test misc-1.2 {error in variable ref. in command in array reference} {
proc tstProc {} "
global a
-
+
set tst \$a(\[winfo name \$\{zz)
# this is a bogus comment
# this is a bogus comment
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1c3ce58..4ab3622 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -55,8 +55,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 +199,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 +693,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 +715,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 +751,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 +860,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 +976,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 +1151,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.test b/tests/namespace.test
index dd71697..0d93092 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -56,7 +56,7 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} {
test namespace-3.1 {Tcl_GetGlobalNamespace} {
namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } }
- # namespace children uses Tcl_GetGlobalNamespace
+ # namespace children uses Tcl_GetGlobalNamespace
namespace eval test_ns_1 {namespace children foo b*}
} {::test_ns_1::foo::bar}
@@ -108,7 +108,7 @@ test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} {
[namespace eval test_ns_2:::::foo {namespace current}]
} {::test_ns_1::foo ::test_ns_2::foo}
test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
- list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
+ list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
} {0 ::test_ns_7}
test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
@@ -205,7 +205,7 @@ test namespace-7.8 {Bug ba1419303b4c} -setup {
namespace delete ns1
}
} -body {
- # No segmentation fault given --enable-symbols=mem.
+ # No segmentation fault given --enable-symbols=mem.
namespace delete ns1
} -result {}
@@ -278,7 +278,7 @@ test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values}
invoked from within
"slave eval error foo bar baz"}
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
- interp create slave
+ interp create slave
slave eval {trace add variable errorCode write {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
@@ -1098,17 +1098,17 @@ test namespace-22.5 {NamespaceCodeCmd, in other namespace} {
namespace code cmd
}
} {::namespace inscope ::test_ns_1 cmd}
-test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
- namespace eval test_ns_1 {
- variable v 42
- }
- namespace eval test_ns_2 {
- proc namespace args {}
- }
- namespace eval test_ns_2 [namespace eval test_ns_1 {
- namespace code {set v}
- }]
-} {42}
+test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
+ namespace eval test_ns_1 {
+ variable v 42
+ }
+ namespace eval test_ns_2 {
+ proc namespace args {}
+ }
+ namespace eval test_ns_2 [namespace eval test_ns_1 {
+ namespace code {set v}
+ }]
+} {42}
test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} {
namespace eval demo {
proc namespace args {puts $args}
@@ -1659,7 +1659,7 @@ test namespace-40.1 {Ignoring namespace proc "unknown"} -setup {
namespace eval ns {proc unknown args {return local}}
list [namespace eval ns aaa bbb] [namespace eval ns aaa]
} -cleanup {
- rename unknown {}
+ rename unknown {}
rename _unknown unknown
namespace delete ns
} -result {global global}
@@ -1670,7 +1670,7 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
set res {}
proc test {} {
set ::g 0
- }
+ }
lappend ::res [test]
proc set {a b} {
::set a [incr b]
diff --git a/tests/nre.test b/tests/nre.test
index 09061d2..58f5511 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -29,9 +29,9 @@ if {[testConstraint testnrelevels]} {
namespace path ::tcl::mathop
#
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
- # cmdFrame level, callFrame level, tosPtr and callback depth
+ # cmdFrame level, callFrame level, tosPtr and callback depth
#
- variable last [testnrelevels]
+ variable last [testnrelevels]
proc depthDiff {} {
variable last
set depth [testnrelevels]
@@ -329,7 +329,7 @@ test nre-8.1 {nre and {*}} -body {
} -cleanup {
rename inner {}
rename outer {}
-} -result {1 1 1}
+} -result {1 1 1}
test nre-8.2 {nre and {*}, [Bug 2415422]} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the bcFramePtr. This causes an NRE assertion to fail if it is not
diff --git a/tests/obj.test b/tests/obj.test
index 7273b40..5bcffa3 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -20,18 +20,16 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
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 {
set r 1
foreach {t} {
- {array search}
bytearray
bytecode
cmdName
dict
- end-offset
regexp
string
} {
@@ -53,15 +51,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]
@@ -82,7 +71,7 @@ test obj-6.1 {Tcl_DuplicateObj, object has internal rep} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testintobj set 1 47]
- lappend result [testobj duplicate 1 2]
+ lappend result [testobj duplicate 1 2]
lappend result [testintobj get 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
@@ -91,7 +80,7 @@ test obj-6.2 {Tcl_DuplicateObj, "empty string" object} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
- lappend result [testobj duplicate 1 2]
+ lappend result [testobj duplicate 1 2]
lappend result [testintobj get 2]
lappend result [testobj refcount 1]
lappend result [testobj refcount 2]
@@ -487,11 +476,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 +489,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 +497,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 +540,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 +548,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 e917bc9..c73c36c 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,13 +13,11 @@ if {"::tcltest" in [namespace children]} {
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 {} {
@@ -131,18 +129,18 @@ 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 {
oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.4.1 {fully-qualified nested name} -body {
- oo::object create ::one::two::three
+ oo::object create ::one::two::three
} -result {::one::two::three}
test oo-1.4.2 {automatic command name has same name as namespace} -body {
set obj [oo::object new]
@@ -365,19 +363,20 @@ 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
@@ -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 {}
@@ -2291,7 +2360,7 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
} -body {
set obj1 [FooClass new]
oo::objdefine $obj1 {
- variable var
+ variable var
method m {} {
set var foo
}
@@ -2340,7 +2409,7 @@ test oo-15.13.1 {
} -cleanup {
Cls destroy
Cls2 destroy
-} -result done
+} -result done
test oo-15.13.2 {OO: object cloning with target NS} -setup {
oo::class create Super
oo::class create Cls {superclass Super}
@@ -2368,7 +2437,7 @@ test oo-15.15 {method cloning must ensure that there is a string representation
} -body {
cls create foo
oo::objdefine foo {
- method m1 {} [string map {a b} {return hello}]
+ method m1 {} [string map {a b} {return hello}]
}
[oo::copy foo] m1
} -cleanup {
@@ -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
@@ -3029,7 +3166,7 @@ test oo-20.10 {OO: variable and varname methods refer to same things} -setup {
test oo-20.11 {OO: variable mustn't crash when recursing} -body {
oo::class create A {
constructor {name} {
- my variable np_name
+ my variable np_name
set np_name $name
}
method copy {nm} {
@@ -3044,7 +3181,7 @@ test oo-20.11 {OO: variable mustn't crash when recursing} -body {
lappend objs [$ref copy {}]
}
$cpy prop $var $objs
- } else {
+ } else {
$cpy prop $var $val
}
}
@@ -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 {
@@ -4181,13 +4380,1112 @@ test oo-35.6 {
return done
} -cleanup {
rename obj {}
-} -result done
+} -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/ooUtil.test b/tests/ooUtil.test
new file mode 100644
index 0000000..ff7093f
--- /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 (c) 2014-2016 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.
+
+package require TclOO 1.0.3
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+ 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 master 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: classvarable} -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: classvarable 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: classvarable 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/package.test b/tests/package.test
index bc73003..2dca06b 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -17,16 +17,22 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $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,56 +612,81 @@ 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 {
coroutine coro1 apply {{} {
package ifneeded t 2.1 {
- yield
+ yield
package provide t 2.1
}
package require t 2.1
}}
list [catch {coro1} msg] $msg
-} -match glob -result {0 2.1}
+} -match glob -result {0 2.1}
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 d73c725..287c392 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -369,7 +369,7 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints {
variable ::aresult
variable ::acode
proc async1 {result code} {
- variable ::aresult
+ variable ::aresult
variable ::acode
set aresult $result
set acode $code
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index ef05454..47dbec5 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -768,11 +768,11 @@ test parseExpr-21.8 {error messages} -body {
expr {0o8x}
} -returnCodes error -match glob -result {*invalid octal number*}
test parseExpr-21.9 {error messages} -body {
- expr {"}
+ expr {"}
} -returnCodes error -result {missing "
in expression """}
test parseExpr-21.10 {error messages} -body {
- expr \{
+ expr \{
} -returnCodes error -result "missing close-brace
in expression \"\{\""
test parseExpr-21.11 {error messages} -body {
@@ -1044,9 +1044,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
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 84c82ce..8ff806c 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -231,7 +231,7 @@ proc pkgtest::runCreatedIndex {rv args} {
set result [list 0 [makePkgList [parseIndex $idxFile]]]
} err]} {
set result [list 1 $err]
- }
+ }
file delete $idxFile
} else {
set result $rv
diff --git a/tests/platform.test b/tests/platform.test
index e5a4c90..53d534e 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -10,7 +10,6 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
-package require tcltests
namespace eval ::tcl::test::platform {
namespace import ::tcltest::testConstraint
@@ -23,8 +22,10 @@ namespace eval ::tcl::test::platform {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+package require tcltests
testConstraint testCPUID [llength [info commands testcpuid]]
+testConstraint testlongsize [llength [info commands testlongsize]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
@@ -39,27 +40,20 @@ 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
test platform-3.1 {CPU ID on Windows/UNIX} \
-constraints testCPUID \
- -body {
+ -body {
set cpudata [testcpuid 0]
binary format iii \
[lindex $cpudata 1] \
[lindex $cpudata 3] \
- [lindex $cpudata 2]
+ [lindex $cpudata 2]
} \
-match regexp \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
diff --git a/tests/proc.test b/tests/proc.test
index 9be056f..43d76d8 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -99,7 +99,7 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e
test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup {
catch {rename p ""}
} -returnCodes error -body {
- proc p {a(1) a(2)} {
+ proc p {a(1) a(2)} {
set z [expr $a(1)+$a(2)]
puts "$z=z, $a(1)=$a(1)"
}
@@ -107,7 +107,7 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup {
catch {rename p ""}
} -body {
- proc p {b:a b::a} {
+ proc p {b:a b::a} {
}
} -returnCodes error -result {formal parameter "b::a" is not a simple name}
test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body {
@@ -340,7 +340,7 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body
} -cleanup {
catch {rename p ""}
catch {rename t ""}
-} -result {aba}
+} -result {aba}
test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body {
proc a {} {return -code -5}
diff --git a/tests/process.test b/tests/process.test
new file mode 100644
index 0000000..229d33c
--- /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 (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.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ 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/reg.test b/tests/reg.test
index a95d1e2..dabd3bc 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -49,9 +49,9 @@ catch [list package require -exact Tcltest [info patchlevel]]
# subexpressions, checking where empty substrings are located,
# etc. should be done using expectIndices and expectPartial.
-# The flag characters are complex and a bit eclectic. Generally speaking,
+# The flag characters are complex and a bit eclectic. Generally speaking,
# lowercase letters are compile options, uppercase are expected re_info
-# bits, and nonalphabetics are match options, controls for how the test is
+# bits, and nonalphabetics are match options, controls for how the test is
# run, or testing options. The one small surprise is that AREs are the
# default, and you must explicitly request lesser flavors of RE. The flags
# are as follows. It is admitted that some are not very mnemonic.
@@ -311,7 +311,7 @@ namespace eval RETest {
# match expected (full fanciness)
# expectIndices testno flags re target mat submat ...
proc expectIndices {args} {
- MatchExpected -indices {*}$args
+ MatchExpected -indices {*}$args
}
# partial match expected
diff --git a/tests/regexp.test b/tests/regexp.test
index 9fff262..bae1217 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -19,6 +19,20 @@ if {"::tcltest" ni [namespace children]} {
unset -nocomplain foo
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
@@ -453,7 +467,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}}
@@ -480,7 +494,7 @@ test regexp-11.12 {regsub without final variable name returns value} {
} {a,bcd,c,ea,bcfd,cf,e}
# This test crashes on the Mac unless you increase the Stack Space to about 1
-# Meg. This is probably bigger than most users want...
+# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
@@ -528,133 +542,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
@@ -740,45 +754,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} -body {
# Bug #461322
- set a abcdefghijklmnopqurstuvwxyz
- set b $a
- set c abcdefghijklmnopqurstuvwxyz0123456789
- regsub $a $c $b d
+ 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"
@@ -1082,13 +1096,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"
@@ -1123,6 +1137,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 01ef06d..8819dd2 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
proc evalInProc { script } {
proc testProc {} $script
set status [catch {
- testProc
+ testProc
} result]
rename testProc {}
return $result
@@ -587,7 +587,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
@@ -607,7 +607,7 @@ test regexpComp-11.8 {regsub errors, -start bad int check} {
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
# This test crashes on the Mac unless you increase the Stack Space to about 1
-# Meg. This is probably bigger than most users want...
+# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
@@ -665,54 +665,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}}
@@ -794,10 +794,10 @@ test regexpComp-19.1 {regsub null replacement} {
test regexpComp-20.1 {regsub shared object shimmering} {
evalInProc {
# Bug #461322
- set a abcdefghijklmnopqurstuvwxyz
- set b $a
- set c abcdefghijklmnopqurstuvwxyz0123456789
- regsub $a $c $b d
+ 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]
diff --git a/tests/result.test b/tests/result.test
index 9e8a66b..859e546 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -31,7 +31,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}
@@ -43,7 +43,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}
diff --git a/tests/safe.test b/tests/safe.test
index 11ad2a9..356e176 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -74,7 +74,7 @@ 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}
test safe-3.1 {calling safe::interpInit is safe} -setup {
catch {safe::interpDelete a}
@@ -92,7 +92,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 {
@@ -464,14 +464,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 {
@@ -526,8 +526,6 @@ test safe-11.7.1 {testing safe encoding} -setup {
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"}
@@ -550,8 +548,6 @@ test safe-11.8.1 {testing safe encoding} -setup {
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"}
@@ -765,7 +761,7 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
-test safe-15.1.1 {safe file ensemble does not surprise code} -setup {
+test safe-15.2 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
diff --git a/tests/scan.test b/tests/scan.test
index 98c581b..eaeaa49 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -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]
}
@@ -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.8 {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 {}
diff --git a/tests/set-old.test b/tests/set-old.test
index 309abaf..ea5155b 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -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/socket.test b/tests/socket.test
index 55b4f2f..fbaade9 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -60,8 +60,13 @@
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
-package require tcltest 2
-namespace import -force ::tcltest::*
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} {
@@ -71,6 +76,7 @@ if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(
# 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 knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
@@ -91,6 +97,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
@@ -277,9 +291,6 @@ proc getPort sock {
lindex [fconfigure $sock -sockname] 2
}
-# Some tests in this file are known to hang *occasionally* on OSX; stop the
-# worst offenders.
-testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# ----------------------------------------------------------------------
@@ -288,13 +299,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 ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? 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 ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? 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}
@@ -303,19 +314,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 ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? 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, -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 ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? 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 ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? 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"}
@@ -325,6 +336,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 -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 -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 -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 -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]
@@ -1930,522 +1959,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} \
+ -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*": socket 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*": socket 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 knownMsvcBug} \
+ -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 {socket 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 {socket 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} \
+ -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} \
+ -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
@@ -2457,7 +2539,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 {
@@ -2474,16 +2557,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 0235bd1..c6cccd6 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -12,8 +12,8 @@
# 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,10 +103,9 @@ 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 {
@@ -241,12 +240,12 @@ test source-7.2 {source -encoding test} -setup {
set sourcefile [makeFile {} source.file]
file delete $sourcefile
set f [open $sourcefile w]
- fconfigure $f -encoding unicode
+ fconfigure $f -encoding utf-16
puts $f "set symbol(square-root) \u221A; set x correct"
close $f
} -body {
set x unset
- source -encoding unicode $sourcefile
+ source -encoding utf-16 $sourcefile
set x
} -cleanup {
removeFile source.file
diff --git a/tests/split.test b/tests/split.test
index 18055b3..d00c452 100644
--- a/tests/split.test
+++ b/tests/split.test
@@ -43,7 +43,7 @@ test split-1.8 {basic split commands} {
foreach f [split {]\n} {}] {
append x $f
}
- return $x
+ return $x
}
foo
} {]\n}
@@ -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\U1F4A9b" {}
+} -result "a \U1F4A9 b"
+test split-1.16 {basic split commands} -body {
+ split "a\U1F4A9b" \U1F4A9
+} -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 13bc524..4c50f74 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -31,7 +31,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} -body {
puts $msg
}
} -result {too many nested evaluations (infinite loop?)}
-
+
# Make sure that there is enough stack to run regexp even if we're
# close to the recursion limit. [Bug 947070] [Patch 746378]
test stack-3.1 {enough room for regexp near recursion limit} -body {
diff --git a/tests/string.test b/tests/string.test
index 124bda7..55989e0 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -20,296 +20,495 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+# 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 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]]
# 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]
+}
-test string-1.1 {error conditions} {
- list [catch {string gorp a b} 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 string-1.2 {error conditions} {
- list [catch {string} msg] $msg
+foreach noComp {0 1} {
+
+if {$noComp} {
+ if {[info commands testevalex] eq {}} {
+ test string-0.1.$noComp "show testevalex availability" {testevalex} {list} {}
+ continue
+ }
+ interp alias {} run {} testevalex
+ set constraints testevalex
+} else {
+ interp alias {} run {} try
+ set constraints {}
+}
+
+
+test string-1.1.$noComp {error conditions} {
+ list [catch {run {string gorp a b}} msg] $msg
+} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, 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 {string compare, too few args} {
- list [catch {string compare a} msg] $msg
+test string-2.1.$noComp {string compare, too few args} {
+ list [catch {run {string compare a}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
-test string-2.2 {string compare, bad args} {
- list [catch {string compare a b c} msg] $msg
+test string-2.2.$noComp {string compare, bad args} {
+ list [catch {run {string compare a b c}} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
-test string-2.3 {string compare, bad args} {
- list [catch {string compare -length -nocase str1 str2} msg] $msg
+test string-2.3.$noComp {string compare, bad args} {
+ list [catch {run {string compare -length -nocase str1 str2}} msg] $msg
} {1 {expected integer but got "-nocase"}}
-test string-2.4 {string compare, too many args} {
- list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
+test string-2.4.$noComp {string compare, too many args} {
+ list [catch {run {string compare -length 10 -nocase str1 str2 str3}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
-test string-2.5 {string compare with length unspecified} {
- list [catch {string compare -length 10 10} msg] $msg
+test string-2.5.$noComp {string compare with length unspecified} {
+ list [catch {run {string compare -length 10 10}} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
-test string-2.6 {string compare} {
- string compare abcde abdef
+test string-2.6.$noComp {string compare} {
+ run {string compare abcde abdef}
} -1
-test string-2.7 {string compare, shortest method name} {
- string co abcde ABCDE
+test string-2.7.$noComp {string compare, shortest method name} {
+ run {string co abcde ABCDE}
} 1
-test string-2.8 {string compare} {
- string compare abcde abcde
+test string-2.8.$noComp {string compare} {
+ run {string compare abcde abcde}
} 0
-test string-2.9 {string compare with length} {
- string compare -length 2 abcde abxyz
+test string-2.9.$noComp {string compare with length} {
+ run {string compare -length 2 abcde abxyz}
} 0
-test string-2.10 {string compare with special index} {
- list [catch {string compare -length end-3 abcde abxyz} msg] $msg
+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 {string compare, unicode} {
- string compare ab\u7266 ab\u7267
+test string-2.11.$noComp {string compare, unicode} {
+ run {string compare ab\u7266 ab\u7267}
} -1
-test string-2.12 {string compare, high bit} {
+test string-2.11.1.$noComp {string compare, unicode} {
+ run {string compare \334 \xDC}
+} 0
+test string-2.11.2.$noComp {string compare, unicode} {
+ run {string compare \334 \xFC}
+} -1
+test string-2.11.3.$noComp {string compare, unicode} {
+ run {string compare \334\334\334\374\374 \334\334\334\334\334}
+} 1
+test string-2.12.$noComp {string compare, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
- string compare "\x80" "@"
+ run {string compare "\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.
} 1
-test string-2.13 {string compare -nocase} {
- string compare -nocase abcde abdef
+test string-2.13.$noComp {string compare -nocase} {
+ run {string compare -nocase abcde abdef}
} -1
-test string-2.14 {string compare -nocase} {
- string compare -nocase abcde ABCDE
+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 {string compare -nocase} {
- string compare -nocase abcde abcde
+test string-2.15.1.$noComp {string compare -nocase} {
+ run {string compare -nocase \334 \xDC}
} 0
-test string-2.16 {string compare -nocase with length} {
- string compare -length 2 -nocase abcde Abxyz
+test string-2.15.2.$noComp {string compare -nocase} {
+ run {string compare -nocase \334\334\334\374\xFC \334\334\334\334\334}
} 0
-test string-2.17 {string compare -nocase with length} {
- string compare -nocase -length 3 abcde Abxyz
+test string-2.16.$noComp {string compare -nocase with length} {
+ run {string compare -length 2 -nocase abcde Abxyz}
+} 0
+test string-2.17.$noComp {string compare -nocase with length} {
+ run {string compare -nocase -length 3 abcde Abxyz}
} -1
-test string-2.18 {string compare -nocase with length <= 0} {
- string compare -nocase -length -1 abcde AbCdEf
+test string-2.18.$noComp {string compare -nocase with length <= 0} {
+ run {string compare -nocase -length -1 abcde AbCdEf}
} -1
-test string-2.19 {string compare -nocase with excessive length} {
- string compare -nocase -length 50 AbCdEf abcde
+test string-2.19.$noComp {string compare -nocase with excessive length} {
+ run {string compare -nocase -length 50 AbCdEf abcde}
} 1
-test string-2.20 {string compare -len unicode} {
+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
- string compare -len 5 \334\334\334 \334\334\374
+ run {string compare -len 5 \334\334\334 \334\334\374}
} -1
-test string-2.21 {string compare -nocase with special index} {
- list [catch {string compare -nocase -length end-3 Abcde abxyz} msg] $msg
+test string-2.21.$noComp {string compare -nocase with special index} {
+ list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
-test string-2.22 {string compare, null strings} {
- string compare "" ""
+test string-2.22.$noComp {string compare, null strings} {
+ run {string compare "" ""}
} 0
-test string-2.23 {string compare, null strings} {
- string compare "" foo
+test string-2.23.$noComp {string compare, null strings} {
+ run {string compare "" foo}
} -1
-test string-2.24 {string compare, null strings} {
- string compare foo ""
+test string-2.24.$noComp {string compare, null strings} {
+ run {string compare foo ""}
} 1
-test string-2.25 {string compare -nocase, null strings} {
- string compare -nocase "" ""
+test string-2.25.$noComp {string compare -nocase, null strings} {
+ run {string compare -nocase "" ""}
} 0
-test string-2.26 {string compare -nocase, null strings} {
- string compare -nocase "" foo
+test string-2.26.$noComp {string compare -nocase, null strings} {
+ run {string compare -nocase "" foo}
} -1
-test string-2.27 {string compare -nocase, null strings} {
- string compare -nocase foo ""
+test string-2.27.$noComp {string compare -nocase, null strings} {
+ run {string compare -nocase foo ""}
} 1
-test string-2.28 {string compare with length, unequal strings} {
- string compare -length 2 abc abde
+test string-2.28.$noComp {string compare with length, unequal strings} {
+ run {string compare -length 2 abc abde}
} 0
-test string-2.29 {string compare with length, unequal strings} {
- string compare -length 2 ab abde
+test string-2.29.$noComp {string compare with length, unequal strings} {
+ run {string compare -length 2 ab abde}
} 0
-test string-2.30 {string compare with NUL character vs. other ASCII} {
+test string-2.30.$noComp {string compare 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
+ run {string compare \x00 \x01}
} -1
-test string-2.31 {string compare, high bit} {
- proc foo {} {string compare "a\x80" "a@"}
- foo
+test string-2.31.$noComp {string compare, high bit} {
+ run {string compare "a\x80" "a@"}
} 1
-test string-2.32 {string compare, high bit} {
- proc foo {} {string compare "a\x00" "a\x01"}
- foo
+test string-2.32.$noComp {string compare, high bit} {
+ run {string compare "a\x00" "a\x01"}
} -1
-test string-2.33 {string compare, high bit} {
- proc foo {} {string compare "\x00\x00" "\x00\x01"}
- foo
+test string-2.33.$noComp {string compare, high bit} {
+ run {string compare "\x00\x00" "\x00\x01"}
} -1
+test string-2.34.$noComp {string compare, binary equal} {
+ run {string compare [binary format a100 0] [binary format a100 0]}
+} 0
+test string-2.35.$noComp {string compare, binary neq} {
+ run {string compare [binary format a100a 0 1] [binary format a100a 0 0]}
+} 1
+test string-2.36.$noComp {string compare, binary neq unequal length} {
+ run {string compare [binary format a20a 0 1] [binary format a100a 0 0]}
+} 1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
-test string-3.1 {string equal} {
- string equal abcde abdef
+test string-3.1.$noComp {string equal} {
+ run {string equal abcde abdef}
} 0
-test string-3.2 {string equal} {
- string eq abcde ABCDE
+test string-3.2.$noComp {string equal} {
+ run {string e abcde ABCDE}
} 0
-test string-3.3 {string equal} {
- string equal abcde abcde
+test string-3.3.$noComp {string equal} {
+ run {string equal abcde abcde}
} 1
-test string-3.4 {string equal -nocase} {
- string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334
+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}
} 1
-test string-3.5 {string equal -nocase} {
- string equal -nocase abcde abdef
+test string-3.5.$noComp {string equal -nocase} {
+ run {string equal -nocase abcde abdef}
} 0
-test string-3.6 {string equal -nocase} {
- string eq -nocase abcde ABCDE
+test string-3.6.$noComp {string equal -nocase} {
+ run {string eq -nocase abcde ABCDE}
} 1
-test string-3.7 {string equal -nocase} {
- string equal -nocase abcde abcde
+test string-3.7.$noComp {string equal -nocase} {
+ run {string equal -nocase abcde abcde}
} 1
-test string-3.8 {string equal with length, unequal strings} {
- string equal -length 2 abc abde
+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, too few 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-4.1 {string first, too few args} {
- list [catch {string first a} msg] $msg
+test string-3.16.$noComp {string equal, unicode} {
+ run {string equal ab\u7266 ab\u7267}
+} 0
+test string-3.17.$noComp {string equal, unicode} {
+ run {string equal \334 \xDC}
+} 1
+test string-3.18.$noComp {string equal, unicode} {
+ run {string equal \334 \xFC}
+} 0
+test string-3.19.$noComp {string equal, unicode} {
+ run {string equal \334\334\334\374\374 \334\334\334\334\334}
+} 0
+test string-3.20.$noComp {string equal, high bit} {
+ # This test will fail if the underlying comparaison
+ # 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 \334 \xDC}
+} 1
+test string-3.23.$noComp {string equal, -nocase unicode} {
+ run {string equal -nocase \334\334\334\374\xFC \334\334\334\334\334}
+} 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 \334\334\334 \334\334\374}
+} 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, too few args} {
+ list [catch {run {string first a}} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
-test string-4.2 {string first, bad args} {
- list [catch {string first a b c} msg] $msg
+test string-4.2.$noComp {string first, bad args} {
+ list [catch {run {string first a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-4.3 {string first, too many args} {
- list [catch {string first a b 5 d} msg] $msg
+test string-4.3.$noComp {string first, too many args} {
+ list [catch {run {string first a b 5 d}} msg] $msg
} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
-test string-4.4 {string first} {
- string first bq abcdefgbcefgbqrs
+test string-4.4.$noComp {string first} {
+ run {string first bq abcdefgbcefgbqrs}
} 12
-test string-4.5 {string first} {
- string fir bcd abcdefgbcefgbqrs
+test string-4.5.$noComp {string first} {
+ run {string fir bcd abcdefgbcefgbqrs}
} 1
-test string-4.6 {string first} {
- string f b abcdefgbcefgbqrs
+test string-4.6.$noComp {string first} {
+ run {string f b abcdefgbcefgbqrs}
} 1
-test string-4.7 {string first} {
- string first xxx x123xx345xxx789xxx012
+test string-4.7.$noComp {string first} {
+ run {string first xxx x123xx345xxx789xxx012}
} 9
-test string-4.8 {string first} {
- string first "" x123xx345xxx789xxx012
+test string-4.8.$noComp {string first} {
+ run {string first "" x123xx345xxx789xxx012}
} -1
-test string-4.9 {string first, unicode} {
- string first x abc\u7266x
+test string-4.9.$noComp {string first, unicode} {
+ run {string first x abc\u7266x}
} 4
-test string-4.10 {string first, unicode} {
- string first \u7266 abc\u7266x
-} 3
-test string-4.11 {string first, start index} {
- string first \u7266 abc\u7266x 3
+test string-4.10.$noComp {string first, unicode} {
+ run {string first \u7266 abc\u7266x}
} 3
-test string-4.12 {string first, start index} {
- string first \u7266 abc\u7266x 4
-} -1
-test string-4.13 {string first, start index} {
- string first \u7266 abc\u7266x end-2
+test string-4.11.$noComp {string first, start index} {
+ run {string first \u7266 abc\u7266x 3}
} 3
-test string-4.14 {string first, negative start index} {
- string first b abc -1
-} 1
-test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
+test string-4.12.$noComp {string first, start index} -body {
+ run {string first \u7266 abc\u7266x 4}
+} -result -1
+test string-4.13.$noComp {string first, start index} -body {
+ run {string first \u7266 abc\u7266x end-2}
+} -result 3
+test string-4.14.$noComp {string first, negative start index} -body {
+ run {string first b abc -1}
+} -result 1
+test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} -body {
# 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
- string first % %#$uchar$uchar#$uchar$uchar#% 3
-} 8
-test string-4.17 {string first, corner case} {
- string first a aaa 4294967295
-} {0}
-test string-4.18 {string first, corner case} {
- string first a aaa -1
-} {0}
-test string-4.19 {string first, corner case} {
- string first a aaa end-5
-} {0}
-test string-4.20 {string last, corner case} {
- string last a aaa 4294967295
-} {-1}
-test string-4.21 {string last, corner case} {
- string last a aaa -1
-} {-1}
-test string-4.22 {string last, corner case} {
- string last a aaa end-5
+ 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]}
+} -result {{string 1} {string 0} 2}
+test string-4.17.$noComp {string first, corner case} -body {
+ run {string first a aaa 4294967295}
+} -result {-1}
+test string-4.18.$noComp {string first, corner case} -body {
+ run {string first a aaa -1}
+} -result {0}
+test string-4.19.$noComp {string first, corner case} -body {
+ run {string first a aaa end-5}
+} -result {0}
+test string-4.20.$noComp {string last, corner case} -body {
+ run {string last a aaa 4294967295}
+} -result {2}
+test string-4.21.$noComp {string last, corner case} -body {
+ run {string last a aaa -1}
+} -result {-1}
+test string-4.22.$noComp {string last, corner case} {
+ run {string last a aaa end-5}
} {-1}
-test string-5.1 {string index} {
- list [catch {string index} msg] $msg
+test string-5.1.$noComp {string index} {
+ list [catch {run {string index}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
-test string-5.2 {string index} {
- list [catch {string index a b c} msg] $msg
+test string-5.2.$noComp {string index} {
+ list [catch {run {string index a b c}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
-test string-5.3 {string index} {
- string index abcde 0
+test string-5.3.$noComp {string index} {
+ run {string index abcde 0}
} a
-test string-5.4 {string index} {
- string in abcde 4
+test string-5.4.$noComp {string index} {
+ run {string ind abcde 4}
} e
-test string-5.5 {string index} {
- string index abcde 5
+test string-5.5.$noComp {string index} {
+ run {string index abcde 5}
} {}
-test string-5.6 {string index} {
- list [catch {string index abcde -10} msg] $msg
+test string-5.6.$noComp {string index} {
+ list [catch {run {string index abcde -10}} msg] $msg
} {0 {}}
-test string-5.7 {string index} {
- list [catch {string index a xyz} msg] $msg
+test string-5.7.$noComp {string index} {
+ list [catch {run {string index a xyz}} msg] $msg
} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-5.8 {string index} {
- string index abc end
+test string-5.8.$noComp {string index} {
+ run {string index abc end}
} c
-test string-5.9 {string index} {
- string index abc end-1
+test string-5.9.$noComp {string index} {
+ run {string index abc end-1}
} b
-test string-5.10 {string index, unicode} {
- string index abc\u7266d 4
+test string-5.10.$noComp {string index, unicode} {
+ run {string index abc\u7266d 4}
} d
-test string-5.11 {string index, unicode} {
- string index abc\u7266d 3
+test string-5.11.$noComp {string index, unicode} {
+ run {string index abc\u7266d 3}
} \u7266
-test string-5.12 {string index, unicode over char length, under byte length} {
- string index \334\374\334\374 6
-} {}
-test string-5.13 {string index, bytearray object} {
- string index [binary format a5 fuz] 0
+test string-5.12.$noComp {string index, unicode over char length, under byte length} -body {
+ run {string index \334\374\334\374 6}
+} -result {}
+test string-5.13.$noComp {string index, bytearray object} {
+ run {string index [binary format a5 fuz] 0}
} f
-test string-5.14 {string index, bytearray object} {
- string index [binary format I* {0x50515253 0x52}] 3
+test string-5.14.$noComp {string index, bytearray object} {
+ run {string index [binary format I* {0x50515253 0x52}] 3}
} S
-test string-5.15 {string index, bytearray object} {
+test string-5.15.$noComp {string index, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
- set i1 [string index $b end-6]
- set i2 [string index $b 1]
- string compare $i1 $i2
+ set i1 [run {string index $b end-6}]
+ set i2 [run {string index $b 1}]
+ run {string compare $i1 $i2}
} 0
-test string-5.16 {string index, bytearray object with string obj shimmering} {
+test string-5.16.$noComp {string index, bytearray object with string obj shimmering} {
set str "0123456789\x00 abcdedfghi"
binary scan $str H* dump
- string compare [string index $str 10] \x00
+ run {string compare [run {string index $str 10}] \x00}
} 0
-test string-5.17 {string index, bad integer} -body {
- list [catch {string index "abc" 0o8} msg] $msg
+test string-5.17.$noComp {string index, bad integer} -body {
+ list [catch {run {string index "abc" 0o8}} msg] $msg
} -match glob -result {1 {*invalid octal number*}}
-test string-5.18 {string index, bad integer} -body {
- list [catch {string index "abc" end-0o0289} msg] $msg
+test string-5.18.$noComp {string index, bad integer} -body {
+ list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*invalid octal number*}}
-test string-5.19 {string index, bytearray object out of bounds} {
- string index [binary format I* {0x50515253 0x52}] -1
-} {}
-test string-5.20 {string index, bytearray object out of bounds} {
- string index [binary format I* {0x50515253 0x52}] 20
+test string-5.19.$noComp {string index, bytearray object out of bounds} {
+ run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
+test string-5.20.$noComp {string index, bytearray object out of bounds} -body {
+ run {string index [binary format I* {0x50515253 0x52}] 20}
+} -result {}
+test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body {
+ run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]}
+} -result [list \U100000 {} b]
proc largest_int {} {
@@ -321,1564 +520,1629 @@ proc largest_int {} {
return [expr {$int-1}]
}
-test string-6.1 {string is, too few args} {
- list [catch {string is} msg] $msg
+test string-6.1.$noComp {string is, too few args} {
+ list [catch {run {string is}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
-test string-6.2 {string is, too few args} {
- list [catch {string is alpha} msg] $msg
+test string-6.2.$noComp {string is, too few args} {
+ list [catch {run {string is alpha}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
-test string-6.3 {string is, bad args} {
- list [catch {string is alpha -failin str} msg] $msg
+test string-6.3.$noComp {string is, bad args} {
+ list [catch {run {string is alpha -failin str}} msg] $msg
} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}}
-test string-6.4 {string is, too many args} {
- list [catch {string is alpha -failin var -strict str more} msg] $msg
+test string-6.4.$noComp {string is, too many args} {
+ list [catch {run {string is alpha -failin var -strict str more}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
-test string-6.5 {string is, class check} {
- list [catch {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}}
-test string-6.6 {string is, ambiguous class} {
- list [catch {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}}
-test string-6.7 {string is alpha, all ok} {
- string is alpha -strict -failindex var abc
-} 1
-test string-6.8 {string is, error in var} {
- list [string is alpha -failindex var abc5def] $var
+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, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, 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, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+test string-6.7.$noComp {string is alpha, all ok} {
+ run {string is alpha -strict -failindex var abc}
+} 1
+test string-6.8.$noComp {string is, error in var} {
+ list [run {string is alpha -failindex var abc5def}] $var
} {0 3}
-test string-6.9 {string is, var shouldn't get set} {
+test string-6.9.$noComp {string is, var shouldn't get set} {
catch {unset var}
- list [catch {string is alpha -failindex var abc; set var} msg] $msg
+ list [catch {run {string is alpha -failindex var abc; set var}} msg] $msg
} {1 {can't read "var": no such variable}}
-test string-6.10 {string is, ok on empty} {
- string is alpha {}
+test string-6.10.$noComp {string is, ok on empty} {
+ run {string is alpha {}}
} 1
-test string-6.11 {string is, -strict check against empty} {
- string is alpha -strict {}
+test string-6.11.$noComp {string is, -strict check against empty} {
+ run {string is alpha -strict {}}
} 0
-test string-6.12 {string is alnum, true} {
- string is alnum abc123
+test string-6.12.$noComp {string is alnum, true} {
+ run {string is alnum abc123}
} 1
-test string-6.13 {string is alnum, false} {
- list [string is alnum -failindex var abc1.23] $var
+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 {string is alnum, unicode} "string is alnum abc\xfc" 1
-test string-6.15 {string is alpha, true} {
- string is alpha abc
+test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xFC}" 1
+test string-6.15.$noComp {string is alpha, true} {
+ run {string is alpha abc}
} 1
-test string-6.16 {string is alpha, false} {
- list [string is alpha -fail var a1bcde] $var
+test string-6.16.$noComp {string is alpha, false} {
+ list [run {string is alpha -fail var a1bcde}] $var
} {0 1}
-test string-6.17 {string is alpha, unicode} {
- string is alpha abc\374
+test string-6.17.$noComp {string is alpha, unicode} {
+ run {string is alpha abc\374}
} 1
-test string-6.18 {string is ascii, true} {
- string is ascii abc\u007Fend\u0000
+test string-6.18.$noComp {string is ascii, true} {
+ run {string is ascii abc\x7Fend\x00}
} 1
-test string-6.19 {string is ascii, false} {
- list [string is ascii -fail var abc\u0000def\u0080more] $var
+test string-6.19.$noComp {string is ascii, false} {
+ list [run {string is ascii -fail var abc\x00def\x80more}] $var
} {0 7}
-test string-6.20 {string is boolean, true} {
- string is boolean true
+test string-6.20.$noComp {string is boolean, true} {
+ run {string is boolean true}
} 1
-test string-6.21 {string is boolean, true} {
- string is boolean f
+test string-6.21.$noComp {string is boolean, true} {
+ run {string is boolean f}
} 1
-test string-6.22 {string is boolean, true based on type} {
- string is bool [string compare a a]
+test string-6.22.$noComp {string is boolean, true based on type} {
+ run {string is bool [run {string compare a a}]}
} 1
-test string-6.23 {string is boolean, false} {
- list [string is bool -fail var yada] $var
+test string-6.23.$noComp {string is boolean, false} {
+ list [run {string is bool -fail var yada}] $var
} {0 0}
-test string-6.24 {string is digit, true} {
- string is digit 0123456789
+test string-6.24.$noComp {string is digit, true} {
+ run {string is digit 0123456789}
} 1
-test string-6.25 {string is digit, false} {
- list [string is digit -fail var 0123\u00DC567] $var
+test string-6.25.$noComp {string is digit, false} {
+ list [run {string is digit -fail var 0123\xDC567}] $var
} {0 4}
-test string-6.26 {string is digit, false} {
- list [string is digit -fail var +123567] $var
+test string-6.26.$noComp {string is digit, false} {
+ list [run {string is digit -fail var +123567}] $var
} {0 0}
-test string-6.27 {string is double, true} {
- string is double 1
+test string-6.27.$noComp {string is double, true} {
+ run {string is double 1}
} 1
-test string-6.28 {string is double, true} {
- string is double [expr double(1)]
+test string-6.28.$noComp {string is double, true} {
+ run {string is double [expr double(1)]}
} 1
-test string-6.29 {string is double, true} {
- string is double 1.0
+test string-6.29.$noComp {string is double, true} {
+ run {string is double 1.0}
} 1
-test string-6.30 {string is double, true} {
- string is double [string compare a a]
+test string-6.30.$noComp {string is double, true} {
+ run {string is double [run {string compare a a}]}
} 1
-test string-6.31 {string is double, true} {
- string is double " +1.0e-1 "
+test string-6.31.$noComp {string is double, true} {
+ run {string is double " +1.0e-1 "}
} 1
-test string-6.32 {string is double, true} {
- string is double "\n1.0\v"
+test string-6.32.$noComp {string is double, true} {
+ run {string is double "\n1.0\v"}
} 1
-test string-6.33 {string is double, false} {
- list [string is double -fail var 1abc] $var
+test string-6.33.$noComp {string is double, false} {
+ list [run {string is double -fail var 1abc}] $var
} {0 1}
-test string-6.34 {string is double, false} {
- list [string is double -fail var abc] $var
+test string-6.34.$noComp {string is double, false} {
+ list [run {string is double -fail var abc}] $var
} {0 0}
-test string-6.35 {string is double, false} {
- list [string is double -fail var " 1.0e4e4 "] $var
+test string-6.35.$noComp {string is double, false} {
+ list [run {string is double -fail var " 1.0e4e4 "}] $var
} {0 8}
-test string-6.36 {string is double, false} {
- list [string is double -fail var "\n"] $var
+test string-6.36.$noComp {string is double, false} {
+ list [run {string is double -fail var "\n"}] $var
} {0 0}
-test string-6.37 {string is double, false on int overflow} -setup {
+test string-6.37.$noComp {string is double, false on int overflow} -setup {
set var priorValue
} -body {
# Make it the largest int recognizable, with one more digit for overflow
# 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 [string is double -fail var [largest_int]0] $var
+ list [run {string is double -fail var [largest_int]0}] $var
} -result {1 priorValue}
# string-6.38 removed, underflow on input is no longer an error.
-test string-6.39 {string is double, false} {
+test string-6.39.$noComp {string is double, false} {
# This test is non-portable because IRIX thinks
# that .e1 is a valid double - this is really a bug
# on IRIX as .e1 should NOT be a valid double
#
# Portable now. Tcl 8.5 does its own double parsing.
- list [string is double -fail var .e1] $var
+ list [run {string is double -fail var .e1}] $var
} {0 0}
-test string-6.40 {string is false, true} {
- string is false false
+test string-6.40.$noComp {string is false, true} {
+ run {string is false false}
} 1
-test string-6.41 {string is false, true} {
- string is false FaLsE
+test string-6.41.$noComp {string is false, true} {
+ run {string is false FaLsE}
} 1
-test string-6.42 {string is false, true} {
- string is false N
+test string-6.42.$noComp {string is false, true} {
+ run {string is false N}
} 1
-test string-6.43 {string is false, true} {
- string is false 0
+test string-6.43.$noComp {string is false, true} {
+ run {string is false 0}
} 1
-test string-6.44 {string is false, true} {
- string is false off
+test string-6.44.$noComp {string is false, true} {
+ run {string is false off}
} 1
-test string-6.45 {string is false, false} {
- list [string is false -fail var abc] $var
+test string-6.45.$noComp {string is false, false} {
+ list [run {string is false -fail var abc}] $var
} {0 0}
-test string-6.46 {string is false, false} {
+test string-6.46.$noComp {string is false, false} {
catch {unset var}
- list [string is false -fail var Y] $var
+ list [run {string is false -fail var Y}] $var
} {0 0}
-test string-6.47 {string is false, false} {
+test string-6.47.$noComp {string is false, false} {
catch {unset var}
- list [string is false -fail var offensive] $var
+ list [run {string is false -fail var offensive}] $var
} {0 0}
-test string-6.48 {string is integer, true} {
- string is integer +1234567890
+test string-6.48.$noComp {string is integer, true} {
+ run {string is integer +1234567890}
} 1
-test string-6.49 {string is integer, true on type} {
- string is integer [expr int(50.0)]
+test string-6.49.$noComp {string is integer, true on type} {
+ run {string is integer [expr int(50.0)]}
} 1
-test string-6.50 {string is integer, true} {
- string is integer [list -10]
+test string-6.50.$noComp {string is integer, true} {
+ run {string is integer [list -10]}
} 1
-test string-6.51 {string is integer, true as hex} {
- string is integer 0xabcdef
+test string-6.51.$noComp {string is integer, true as hex} {
+ run {string is integer 0xabcdef}
} 1
-test string-6.52 {string is integer, true as octal} {
- string is integer 012345
+test string-6.52.$noComp {string is integer, true as octal} {
+ run {string is integer 012345}
} 1
-test string-6.53 {string is integer, true with whitespace} {
- string is integer " \n1234\v"
+test string-6.53.$noComp {string is integer, true with whitespace} {
+ run {string is integer " \n1234\v"}
} 1
-test string-6.54 {string is integer, false} {
- list [string is integer -fail var 123abc] $var
+test string-6.54.$noComp {string is integer, false} {
+ list [run {string is integer -fail var 123abc}] $var
} {0 3}
-test string-6.55 {string is integer, false on overflow} {
- list [string is integer -fail var +[largest_int]0] $var
-} {0 -1}
-test string-6.56 {string is integer, false} {
- list [string is integer -fail var [expr double(1)]] $var
+test string-6.55.$noComp {string is integer, no overflow possible} {
+ run {string is integer +[largest_int]0}
+} 1
+test string-6.56.$noComp {string is integer, false} {
+ list [run {string is integer -fail var [expr double(1)]}] $var
} {0 1}
-test string-6.57 {string is integer, false} {
- list [string is integer -fail var " "] $var
+test string-6.57.$noComp {string is integer, false} {
+ list [run {string is integer -fail var " "}] $var
} {0 0}
-test string-6.58 {string is integer, false on bad octal} {
- list [string is integer -fail var 0o36963] $var
+test string-6.58.$noComp {string is integer, false on bad octal} {
+ list [run {string is integer -fail var 0o36963}] $var
} {0 4}
-test string-6.58.1 {string is integer, false on bad octal} {
- list [string is integer -fail var 0o36963] $var
+test string-6.58.1.$noComp {string is integer, false on bad octal} {
+ list [run {string is integer -fail var 0o36963}] $var
} {0 4}
-test string-6.59 {string is integer, false on bad hex} {
- list [string is integer -fail var 0X345XYZ] $var
+test string-6.59.$noComp {string is integer, false on bad hex} {
+ list [run {string is integer -fail var 0X345XYZ}] $var
} {0 5}
-test string-6.60 {string is lower, true} {
- string is lower abc
+test string-6.60.$noComp {string is lower, true} {
+ run {string is lower abc}
} 1
-test string-6.61 {string is lower, unicode true} {
- string is lower abc\u00FCue
+test string-6.61.$noComp {string is lower, unicode true} {
+ run {string is lower abc\xFCue}
} 1
-test string-6.62 {string is lower, false} {
- list [string is lower -fail var aBc] $var
+test string-6.62.$noComp {string is lower, false} {
+ list [run {string is lower -fail var aBc}] $var
} {0 1}
-test string-6.63 {string is lower, false} {
- list [string is lower -fail var abc1] $var
+test string-6.63.$noComp {string is lower, false} {
+ list [run {string is lower -fail var abc1}] $var
} {0 3}
-test string-6.64 {string is lower, unicode false} {
- list [string is lower -fail var ab\u00DCUE] $var
+test string-6.64.$noComp {string is lower, unicode false} {
+ list [run {string is lower -fail var ab\xDCUE}] $var
} {0 2}
-test string-6.65 {string is space, true} {
- string is space " \t\n\v\f"
+test string-6.65.$noComp {string is space, true} {
+ run {string is space " \t\n\v\f"}
} 1
-test string-6.66 {string is space, false} {
- list [string is space -fail var " \t\n\v1\f"] $var
+test string-6.66.$noComp {string is space, false} {
+ list [run {string is space -fail var " \t\n\v1\f"}] $var
} {0 4}
-test string-6.67 {string is true, true} {
- string is true true
+test string-6.67.$noComp {string is true, true} {
+ run {string is true true}
} 1
-test string-6.68 {string is true, true} {
- string is true TrU
+test string-6.68.$noComp {string is true, true} {
+ run {string is true TrU}
} 1
-test string-6.69 {string is true, true} {
- string is true ye
+test string-6.69.$noComp {string is true, true} {
+ run {string is true ye}
} 1
-test string-6.70 {string is true, true} {
- string is true 1
+test string-6.70.$noComp {string is true, true} {
+ run {string is true 1}
} 1
-test string-6.71 {string is true, true} {
- string is true on
+test string-6.71.$noComp {string is true, true} {
+ run {string is true on}
} 1
-test string-6.72 {string is true, false} {
- list [string is true -fail var onto] $var
+test string-6.72.$noComp {string is true, false} {
+ list [run {string is true -fail var onto}] $var
} {0 0}
-test string-6.73 {string is true, false} {
+test string-6.73.$noComp {string is true, false} {
catch {unset var}
- list [string is true -fail var 25] $var
+ list [run {string is true -fail var 25}] $var
} {0 0}
-test string-6.74 {string is true, false} {
+test string-6.74.$noComp {string is true, false} {
catch {unset var}
- list [string is true -fail var no] $var
+ list [run {string is true -fail var no}] $var
} {0 0}
-test string-6.75 {string is upper, true} {
- string is upper ABC
+test string-6.75.$noComp {string is upper, true} {
+ run {string is upper ABC}
} 1
-test string-6.76 {string is upper, unicode true} {
- string is upper ABC\u00DCUE
+test string-6.76.$noComp {string is upper, unicode true} {
+ run {string is upper ABC\xDCUE}
} 1
-test string-6.77 {string is upper, false} {
- list [string is upper -fail var AbC] $var
+test string-6.77.$noComp {string is upper, false} {
+ list [run {string is upper -fail var AbC}] $var
} {0 1}
-test string-6.78 {string is upper, false} {
- list [string is upper -fail var AB2C] $var
+test string-6.78.$noComp {string is upper, false} {
+ list [run {string is upper -fail var AB2C}] $var
} {0 2}
-test string-6.79 {string is upper, unicode false} {
- list [string is upper -fail var ABC\u00FCue] $var
+test string-6.79.$noComp {string is upper, unicode false} {
+ list [run {string is upper -fail var ABC\xFCue}] $var
} {0 3}
-test string-6.80 {string is wordchar, true} {
- string is wordchar abc_123
+test string-6.80.$noComp {string is wordchar, true} {
+ run {string is wordchar abc_123}
} 1
-test string-6.81 {string is wordchar, unicode true} {
- string is wordchar abc\u00FCab\u00DCAB\u5001
+test string-6.81.$noComp {string is wordchar, unicode true} {
+ run {string is wordchar abc\xFCab\xDCAB\u5001\U1D7CA}
} 1
-test string-6.82 {string is wordchar, false} {
- list [string is wordchar -fail var abcd.ef] $var
+test string-6.82.$noComp {string is wordchar, false} {
+ list [run {string is wordchar -fail var abcd.ef}] $var
} {0 4}
-test string-6.83 {string is wordchar, unicode false} {
- list [string is wordchar -fail var abc\u0080def] $var
+test string-6.83.$noComp {string is wordchar, unicode false} {
+ list [run {string is wordchar -fail var abc\x80def}] $var
} {0 3}
-test string-6.84 {string is control} {
+test string-6.84.$noComp {string is control} {
## Control chars are in the ranges
## 00..1F && 7F..9F
- list [string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60] $var
+ list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var
} {0 7}
-test string-6.85 {string is control} {
- string is control \u0100
+test string-6.85.$noComp {string is control} {
+ run {string is control \u0100}
} 0
-test string-6.86 {string is graph} {
+test string-6.86.$noComp {string is graph} {
## graph is any print char, except space
- list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var
+ list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var
} {0 14}
-test string-6.87 {string is print} {
+test string-6.87.$noComp {string is print} {
## basically any printable char
- list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var
+ list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\x10"}] $var
} {0 15}
-test string-6.88 {string is punct} {
+test string-6.88.$noComp {string is punct} {
## any graph char that isn't alnum
- list [string is punct -fail var "_!@#\u00BEq0"] $var
+ list [run {string is punct -fail var "_!@#\xBEq0"}] $var
} {0 4}
-test string-6.89 {string is xdigit} {
- list [string is xdigit -fail var 0123456789\u0061bcdefABCDEFg] $var
+test string-6.89.$noComp {string is xdigit} {
+ list [run {string is xdigit -fail var 0123456789\x61bcdefABCDEFg}] $var
} {0 22}
-test string-6.90 {string is integer, bad integers} {
+test string-6.90.$noComp {string is integer, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
- lappend result [string is int -strict $num]
+ lappend result [run {string is int -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
-test string-6.91 {string is double, bad doubles} {
+test string-6.91.$noComp {string is double, bad doubles} {
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
- lappend result [string is double -strict $num]
+ lappend result [run {string is double -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
-test string-6.92 {string is integer, 32-bit overflow} {
+test string-6.92.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
- set x 0x100000000
- list [string is integer -failindex var $x] $var
-} {0 -1}
-test string-6.93 {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 [string is integer -failindex var $x] $var
-} {0 -1}
-test string-6.94 {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 [string is integer -failindex var [expr {$x}]] $var
-} {0 -1}
-test string-6.95 {string is wideinteger, true} {
- string is wideinteger +1234567890
+ set x 0x10000000000000000
+ run {string is integer [expr {$x}]}
} 1
-test string-6.96 {string is wideinteger, true on type} {
- string is wideinteger [expr wide(50.0)]
+test string-6.95.$noComp {string is wideinteger, true} {
+ run {string is wideinteger +1234567890}
} 1
-test string-6.97 {string is wideinteger, true} {
- string is wideinteger [list -10]
+test string-6.96.$noComp {string is wideinteger, true on type} {
+ run {string is wideinteger [expr wide(50.0)]}
} 1
-test string-6.98 {string is wideinteger, true as hex} {
- string is wideinteger 0xabcdef
+test string-6.97.$noComp {string is wideinteger, true} {
+ run {string is wideinteger [list -10]}
} 1
-test string-6.99 {string is wideinteger, true as octal} {
- string is wideinteger 0123456
+test string-6.98.$noComp {string is wideinteger, true as hex} {
+ run {string is wideinteger 0xabcdef}
} 1
-test string-6.100 {string is wideinteger, true with whitespace} {
- string is wideinteger " \n1234\v"
+test string-6.99.$noComp {string is wideinteger, true as octal} {
+ run {string is wideinteger 0123456}
} 1
-test string-6.101 {string is wideinteger, false} {
- list [string is wideinteger -fail var 123abc] $var
+test string-6.100.$noComp {string is wideinteger, true with whitespace} {
+ run {string is wideinteger " \n1234\v"}
+} 1
+test string-6.101.$noComp {string is wideinteger, false} {
+ list [run {string is wideinteger -fail var 123abc}] $var
} {0 3}
-test string-6.102 {string is wideinteger, false on overflow} {
- list [string is wideinteger -fail var +[largest_int]0] $var
+test string-6.102.$noComp {string is wideinteger, false on overflow} {
+ list [run {string is wideinteger -fail var +[largest_int]0}] $var
} {0 -1}
-test string-6.103 {string is wideinteger, false} {
- list [string is wideinteger -fail var [expr double(1)]] $var
+test string-6.103.$noComp {string is wideinteger, false} {
+ list [run {string is wideinteger -fail var [expr double(1)]}] $var
} {0 1}
-test string-6.104 {string is wideinteger, false} {
- list [string is wideinteger -fail var " "] $var
+test string-6.104.$noComp {string is wideinteger, false} {
+ list [run {string is wideinteger -fail var " "}] $var
} {0 0}
-test string-6.105 {string is wideinteger, false on bad octal} {
- list [string is wideinteger -fail var 0o36963] $var
+test string-6.105.$noComp {string is wideinteger, false on bad octal} {
+ list [run {string is wideinteger -fail var 0o36963}] $var
} {0 4}
-test string-6.105.1 {string is wideinteger, false on bad octal} {
- list [string is wideinteger -fail var 0o36963] $var
+test string-6.105.1.$noComp {string is wideinteger, false on bad octal} {
+ list [run {string is wideinteger -fail var 0o36963}] $var
} {0 4}
-test string-6.106 {string is wideinteger, false on bad hex} {
- list [string is wideinteger -fail var 0X345XYZ] $var
+test string-6.106.$noComp {string is wideinteger, false on bad hex} {
+ list [run {string is wideinteger -fail var 0X345XYZ}] $var
} {0 5}
-test string-6.107 {string is integer, bad integers} {
+test string-6.107.$noComp {string is integer, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
- lappend result [string is wideinteger -strict $num]
+ lappend result [run {string is wideinteger -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
-test string-6.108 {string is double, Bug 1382287} {
+test string-6.108.$noComp {string is double, Bug 1382287} {
set x 2turtledoves
- string is double $x
- string is double $x
+ run {string is double $x}
+ run {string is double $x}
} 0
-test string-6.109 {string is double, Bug 1360532} {
- string is double 1\u00A0
+test string-6.109.$noComp {string is double, Bug 1360532} {
+ run {string is double 1\xA0}
} 0
-test string-6.110 {string is entier, true} {
- string is entier +1234567890
+test string-6.110.$noComp {string is entier, true} {
+ run {string is entier +1234567890}
} 1
-test string-6.111 {string is entier, true on type} {
- string is entier [expr wide(50.0)]
+test string-6.111.$noComp {string is entier, true on type} {
+ run {string is entier [expr wide(50.0)]}
} 1
-test string-6.112 {string is entier, true} {
- string is entier [list -10]
+test string-6.112.$noComp {string is entier, true} {
+ run {string is entier [list -10]}
} 1
-test string-6.113 {string is entier, true as hex} {
- string is entier 0xabcdef
+test string-6.113.$noComp {string is entier, true as hex} {
+ run {string is entier 0xabcdef}
} 1
-test string-6.114 {string is entier, true as octal} {
- string is entier 0123456
+test string-6.114.$noComp {string is entier, true as octal} {
+ run {string is entier 0123456}
} 1
-test string-6.115 {string is entier, true with whitespace} {
- string is entier " \n1234\v"
+test string-6.115.$noComp {string is entier, true with whitespace} {
+ run {string is entier " \n1234\v"}
} 1
-test string-6.116 {string is entier, false} {
- list [string is entier -fail var 123abc] $var
+test string-6.116.$noComp {string is entier, false} {
+ list [run {string is entier -fail var 123abc}] $var
} {0 3}
-test string-6.117 {string is entier, false} {
- list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var
+test string-6.117.$noComp {string is entier, false} {
+ list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var
} {0 84}
-test string-6.118 {string is entier, false} {
- list [string is entier -fail var [expr double(1)]] $var
+test string-6.118.$noComp {string is entier, false} {
+ list [run {string is entier -fail var [expr double(1)]}] $var
} {0 1}
-test string-6.119 {string is entier, false} {
- list [string is entier -fail var " "] $var
+test string-6.119.$noComp {string is entier, false} {
+ list [run {string is entier -fail var " "}] $var
} {0 0}
-test string-6.120 {string is entier, false on bad octal} {
- list [string is entier -fail var 0o36963] $var
+test string-6.120.$noComp {string is entier, false on bad octal} {
+ list [run {string is entier -fail var 0o36963}] $var
} {0 4}
-test string-6.121.1 {string is entier, false on bad octal} {
- list [string is entier -fail var 0o36963] $var
+test string-6.121.1.$noComp {string is entier, false on bad octal} {
+ list [run {string is entier -fail var 0o36963}] $var
} {0 4}
-test string-6.122 {string is entier, false on bad hex} {
- list [string is entier -fail var 0X345XYZ] $var
+test string-6.122.$noComp {string is entier, false on bad hex} {
+ list [run {string is entier -fail var 0X345XYZ}] $var
} {0 5}
-test string-6.123 {string is entier, bad integers} {
+test string-6.123.$noComp {string is entier, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
- lappend result [string is entier -strict $num]
+ lappend result [run {string is entier -strict $num}]
}
return $result
} {1 1 0 0 0 1 0 0}
-test string-6.124 {string is entier, true} {
- string is entier +1234567890123456789012345678901234567890
+test string-6.124.$noComp {string is entier, true} {
+ run {string is entier +1234567890123456789012345678901234567890}
} 1
-test string-6.125 {string is entier, true} {
- string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]
+test string-6.125.$noComp {string is entier, true} {
+ run {string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]}
} 1
-test string-6.126 {string is entier, true as hex} {
- string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef
+test string-6.126.$noComp {string is entier, true as hex} {
+ run {string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef}
} 1
-test string-6.127 {string is entier, true as octal} {
- string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456
+test string-6.127.$noComp {string is entier, true as octal} {
+ run {string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456}
} 1
-test string-6.128 {string is entier, true with whitespace} {
- string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"
+test string-6.128.$noComp {string is entier, true with whitespace} {
+ run {string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"}
} 1
-test string-6.129 {string is entier, false on bad octal} {
- list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+test string-6.129.$noComp {string is entier, false on bad octal} {
+ list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var
} {0 87}
-test string-6.130.1 {string is entier, false on bad octal} {
- list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+test string-6.130.1.$noComp {string is entier, false on bad octal} {
+ list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var
} {0 87}
-test string-6.131 {string is entier, false on bad hex} {
- list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var
+test string-6.131.$noComp {string is entier, false on bad hex} {
+ list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var
} {0 88}
catch {rename largest_int {}}
-test string-7.1 {string last, too few args} {
- list [catch {string last a} msg] $msg
-} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
-test string-7.2 {string last, bad args} {
- list [catch {string last a b c} msg] $msg
+test string-7.1.$noComp {string last, too few args} {
+ list [catch {run {string last a}} msg] $msg
+} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
+test string-7.2.$noComp {string last, bad args} {
+ list [catch {run {string last a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-7.3 {string last, too many args} {
- list [catch {string last a b c d} msg] $msg
-} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
-test string-7.4 {string last} {
- string la xxx xxxx123xx345x678
-} 1
-test string-7.5 {string last} {
- string last xx xxxx123xx345x678
+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 ?lastIndex?"}}
+test string-7.4.$noComp {string last} {
+ run {string la xxx xxxx123xx345x678}
+} 1
+test string-7.5.$noComp {string last} {
+ run {string last xx xxxx123xx345x678}
} 7
-test string-7.6 {string last} {
- string las x xxxx123xx345x678
+test string-7.6.$noComp {string last} {
+ run {string las x xxxx123xx345x678}
} 12
-test string-7.7 {string last, unicode} {
- string las x xxxx12\u7266xx345x678
+test string-7.7.$noComp {string last, unicode} {
+ run {string las x xxxx12\u7266xx345x678}
} 12
-test string-7.8 {string last, unicode} {
- string las \u7266 xxxx12\u7266xx345x678
+test string-7.8.$noComp {string last, unicode} {
+ run {string las \u7266 xxxx12\u7266xx345x678}
} 6
-test string-7.9 {string last, stop index} {
- string las \u7266 xxxx12\u7266xx345x678
+test string-7.9.$noComp {string last, stop index} {
+ run {string las \u7266 xxxx12\u7266xx345x678}
} 6
-test string-7.10 {string last, unicode} {
- string las \u7266 xxxx12\u7266xx345x678
+test string-7.10.$noComp {string last, unicode} {
+ run {string las \u7266 xxxx12\u7266xx345x678}
} 6
-test string-7.11 {string last, start index} {
- string last \u7266 abc\u7266x 3
+test string-7.11.$noComp {string last, start index} {
+ run {string last \u7266 abc\u7266x 3}
} 3
-test string-7.12 {string last, start index} {
- string last \u7266 abc\u7266x 2
+test string-7.12.$noComp {string last, start index} {
+ run {string last \u7266 abc\u7266x 2}
} -1
-test string-7.13 {string last, start index} {
+test string-7.13.$noComp {string last, start index} {
## Constrain to last 'a' should work
- string last ba badbad end-1
+ run {string last ba badbad end-1}
} 3
-test string-7.14 {string last, start index} {
+test string-7.14.$noComp {string last, start index} {
## Constrain to last 'b' should skip last 'ba'
- string last ba badbad end-2
+ run {string last ba badbad end-2}
} 0
-test string-7.15 {string last, start index} {
- string last \334a \334ad\334ad 0
+test string-7.15.$noComp {string last, start index} {
+ run {string last \334a \334ad\334ad 0}
} -1
-test string-7.16 {string last, start index} {
- string last \334a \334ad\334ad end-1
+test string-7.16.$noComp {string last, start index} {
+ run {string last \334a \334ad\334ad end-1}
} 3
-test string-8.1 {string bytelength} {
- list [catch {string bytelength} msg] $msg
+test string-8.1.$noComp {string bytelength} {
+ list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
-test string-8.2 {string bytelength} {
- list [catch {string bytelength a b} msg] $msg
+test string-8.2.$noComp {string bytelength} {
+ list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
-test string-8.3 {string bytelength} {
- string bytelength "\u00c7"
+test string-8.3.$noComp {string bytelength} {
+ run {string bytelength "\xC7"}
} 2
-test string-8.4 {string bytelength} {
- string b ""
+test string-8.4.$noComp {string bytelength} {
+ run {string b ""}
} 0
-test string-9.1 {string length} {
- list [catch {string length} msg] $msg
+test string-9.1.$noComp {string length} {
+ list [catch {run {string length}} msg] $msg
} {1 {wrong # args: should be "string length string"}}
-test string-9.2 {string length} {
- list [catch {string length a b} msg] $msg
+test string-9.2.$noComp {string length} {
+ list [catch {run {string length a b}} msg] $msg
} {1 {wrong # args: should be "string length string"}}
-test string-9.3 {string length} {
- string length "a little string"
+test string-9.3.$noComp {string length} {
+ run {string length "a little string"}
} 15
-test string-9.4 {string length} {
- string le ""
+test string-9.4.$noComp {string length} {
+ run {string le ""}
} 0
-test string-9.5 {string length, unicode} {
- string le "abcd\u7266"
+test string-9.5.$noComp {string length, unicode} {
+ run {string le "abcd\u7266"}
} 5
-test string-9.6 {string length, bytearray object} {
- string length [binary format a5 foo]
+test string-9.6.$noComp {string length, bytearray object} {
+ run {string length [binary format a5 foo]}
} 5
-test string-9.7 {string length, bytearray object} {
- string length [binary format I* {0x50515253 0x52}]
+test string-9.7.$noComp {string length, bytearray object} {
+ run {string length [binary format I* {0x50515253 0x52}]}
} 8
-test string-10.1 {string map, too few args} {
- list [catch {string map} msg] $msg
+test string-10.1.$noComp {string map, too few args} {
+ list [catch {run {string map}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
-test string-10.2 {string map, bad args} {
- list [catch {string map {a b} abba oops} msg] $msg
+test string-10.2.$noComp {string map, bad args} {
+ list [catch {run {string map {a b} abba oops}} msg] $msg
} {1 {bad option "a b": must be -nocase}}
-test string-10.3 {string map, too many args} {
- list [catch {string map -nocase {a b} str1 str2} msg] $msg
+test string-10.3.$noComp {string map, too many args} {
+ list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
-test string-10.4 {string map} {
- string map {a b} abba
+test string-10.4.$noComp {string map} {
+ run {string map {a b} abba}
} {bbbb}
-test string-10.5 {string map} {
- string map {a b} a
+test string-10.5.$noComp {string map} {
+ run {string map {a b} a}
} {b}
-test string-10.6 {string map -nocase} {
- string map -nocase {a b} Abba
+test string-10.6.$noComp {string map -nocase} {
+ run {string map -nocase {a b} Abba}
} {bbbb}
-test string-10.7 {string map} {
- string map {abc 321 ab * a A} aabcabaababcab
+test string-10.7.$noComp {string map} {
+ run {string map {abc 321 ab * a A} aabcabaababcab}
} {A321*A*321*}
-test string-10.8 {string map -nocase} {
- string map -nocase {aBc 321 Ab * a A} aabcabaababcab
+test string-10.8.$noComp {string map -nocase} {
+ run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab}
} {A321*A*321*}
-test string-10.9 {string map -nocase} {
- string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb
+test string-10.9.$noComp {string map -nocase} {
+ run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb}
} {A321*A*321*}
-test string-10.10 {string map} {
- list [catch {string map {a b c} abba} msg] $msg
+test string-10.10.$noComp {string map} {
+ list [catch {run {string map {a b c} abba}} msg] $msg
} {1 {char map list unbalanced}}
-test string-10.11 {string map, nulls} {
- string map {\x00 NULL blah \x00nix} {qwerty}
+test string-10.11.$noComp {string map, nulls} {
+ run {string map {\x00 NULL blah \x00nix} {qwerty}}
} {qwerty}
-test string-10.12 {string map, unicode} {
- string map [list \374 ue UE \334] "a\374ueUE\000EU"
+test string-10.12.$noComp {string map, unicode} {
+ run {string map [list \374 ue UE \334] "a\374ueUE\000EU"}
} aueue\334\0EU
-test string-10.13 {string map, -nocase unicode} {
- string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"
+test string-10.13.$noComp {string map, -nocase unicode} {
+ run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"}
} aue\334\334\0EU
-test string-10.14 {string map, -nocase null arguments} {
- string map -nocase {{} abc} foo
+test string-10.14.$noComp {string map, -nocase null arguments} {
+ run {string map -nocase {{} abc} foo}
} foo
-test string-10.15 {string map, one pair case} {
- string map -nocase {abc 32} aAbCaBaAbAbcAb
+test string-10.15.$noComp {string map, one pair case} {
+ run {string map -nocase {abc 32} aAbCaBaAbAbcAb}
} {a32aBaAb32Ab}
-test string-10.16 {string map, one pair case} {
- string map -nocase {ab 4321} aAbCaBaAbAbcAb
+test string-10.16.$noComp {string map, one pair case} {
+ run {string map -nocase {ab 4321} aAbCaBaAbAbcAb}
} {a4321C4321a43214321c4321}
-test string-10.17 {string map, one pair case} {
- string map {Ab 4321} aAbCaBaAbAbcAb
+test string-10.17.$noComp {string map, one pair case} {
+ run {string map {Ab 4321} aAbCaBaAbAbcAb}
} {a4321CaBa43214321c4321}
-test string-10.18 {string map, empty argument} {
- string map -nocase {{} abc} foo
+test string-10.18.$noComp {string map, empty argument} {
+ run {string map -nocase {{} abc} foo}
} foo
-test string-10.19 {string map, empty arguments} {
- string map -nocase {{} abc f bar {} def} foo
+test string-10.19.$noComp {string map, empty arguments} {
+ run {string map -nocase {{} abc f bar {} def} foo}
} baroo
-test string-10.20 {string map, dictionaries don't alter map ordering} {
+test string-10.20.$noComp {string map, dictionaries don't alter map ordering} {
set map {aa X a Y}
- list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
+ list [run {string map [dict create aa X a Y] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}]
} {XY XY 2 XY}
-test string-10.20.1 {string map, dictionaries don't alter map ordering} {
+test string-10.20.1.$noComp {string map, dictionaries don't alter map ordering} {
set map {a X b Y a Z}
- list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
+ list [run {string map [dict create a X b Y a Z] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}]
} {ZZZ XXX 2 XXX}
-test string-10.21 {string map, ABR checks} {
- string map {longstring foob} long
+test string-10.21.$noComp {string map, ABR checks} {
+ run {string map {longstring foob} long}
} long
-test string-10.22 {string map, ABR checks} {
- string map {long foob} long
+test string-10.22.$noComp {string map, ABR checks} {
+ run {string map {long foob} long}
} foob
-test string-10.23 {string map, ABR checks} {
- string map {lon foob} long
+test string-10.23.$noComp {string map, ABR checks} {
+ run {string map {lon foob} long}
} foobg
-test string-10.24 {string map, ABR checks} {
- string map {lon foob} longlo
+test string-10.24.$noComp {string map, ABR checks} {
+ run {string map {lon foob} longlo}
} foobglo
-test string-10.25 {string map, ABR checks} {
- string map {lon foob} longlon
+test string-10.25.$noComp {string map, ABR checks} {
+ run {string map {lon foob} longlon}
} foobgfoob
-test string-10.26 {string map, ABR checks} {
- string map {longstring foob longstring bar} long
+test string-10.26.$noComp {string map, ABR checks} {
+ run {string map {longstring foob longstring bar} long}
} long
-test string-10.27 {string map, ABR checks} {
- string map {long foob longstring bar} long
+test string-10.27.$noComp {string map, ABR checks} {
+ run {string map {long foob longstring bar} long}
} foob
-test string-10.28 {string map, ABR checks} {
- string map {lon foob longstring bar} long
+test string-10.28.$noComp {string map, ABR checks} {
+ run {string map {lon foob longstring bar} long}
} foobg
-test string-10.29 {string map, ABR checks} {
- string map {lon foob longstring bar} longlo
+test string-10.29.$noComp {string map, ABR checks} {
+ run {string map {lon foob longstring bar} longlo}
} foobglo
-test string-10.30 {string map, ABR checks} {
- string map {lon foob longstring bar} longlon
+test string-10.30.$noComp {string map, ABR checks} {
+ run {string map {lon foob longstring bar} longlon}
} foobgfoob
-test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} {
+test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} {
set a {a b}
- string map $a $a
+ run {string map $a $a}
} {b b}
-test string-11.1 {string match, too few args} {
- list [catch {string match a} msg] $msg
+test string-11.1.$noComp {string match, too few args} {
+ list [catch {run {string match a}} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
-test string-11.2 {string match, too many args} {
- list [catch {string match a b c d} msg] $msg
+test string-11.2.$noComp {string match, too many args} {
+ list [catch {run {string match a b c d}} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
-test string-11.3 {string match} {
- string match abc abc
+test string-11.3.$noComp {string match} {
+ run {string match abc abc}
} 1
-test string-11.4 {string match} {
- string mat abc abd
+test string-11.4.$noComp {string match} {
+ run {string mat abc abd}
} 0
-test string-11.5 {string match} {
- string match ab*c abc
+test string-11.5.$noComp {string match} {
+ run {string match ab*c abc}
} 1
-test string-11.6 {string match} {
- string match ab**c abc
+test string-11.6.$noComp {string match} {
+ run {string match ab**c abc}
} 1
-test string-11.7 {string match} {
- string match ab* abcdef
+test string-11.7.$noComp {string match} {
+ run {string match ab* abcdef}
} 1
-test string-11.8 {string match} {
- string match *c abc
+test string-11.8.$noComp {string match} {
+ run {string match *c abc}
} 1
-test string-11.9 {string match} {
- string match *3*6*9 0123456789
+test string-11.9.$noComp {string match} {
+ run {string match *3*6*9 0123456789}
} 1
-test string-11.9.1 {string match} {
- string match *3*6*89 0123456789
+test string-11.9.1.$noComp {string match} {
+ run {string match *3*6*89 0123456789}
} 1
-test string-11.9.2 {string match} {
- string match *3*456*89 0123456789
+test string-11.9.2.$noComp {string match} {
+ run {string match *3*456*89 0123456789}
} 1
-test string-11.9.3 {string match} {
- string match *3*6* 0123456789
+test string-11.9.3.$noComp {string match} {
+ run {string match *3*6* 0123456789}
} 1
-test string-11.9.4 {string match} {
- string match *3*56* 0123456789
+test string-11.9.4.$noComp {string match} {
+ run {string match *3*56* 0123456789}
} 1
-test string-11.9.5 {string match} {
- string match *3*456*** 0123456789
+test string-11.9.5.$noComp {string match} {
+ run {string match *3*456*** 0123456789}
} 1
-test string-11.9.6 {string match} {
- string match **3*456** 0123456789
+test string-11.9.6.$noComp {string match} {
+ run {string match **3*456** 0123456789}
} 1
-test string-11.9.7 {string match} {
- string match *3***456* 0123456789
+test string-11.9.7.$noComp {string match} {
+ run {string match *3***456* 0123456789}
} 1
-test string-11.9.8 {string match} {
- string match *3***\[456]* 0123456789
+test string-11.9.8.$noComp {string match} {
+ run {string match *3***\[456]* 0123456789}
} 1
-test string-11.9.9 {string match} {
- string match *3***\[4-6]* 0123456789
+test string-11.9.9.$noComp {string match} {
+ run {string match *3***\[4-6]* 0123456789}
} 1
-test string-11.9.10 {string match} {
- string match *3***\[4-6] 0123456789
+test string-11.9.10.$noComp {string match} {
+ run {string match *3***\[4-6] 0123456789}
} 0
-test string-11.9.11 {string match} {
- string match *3***\[4-6] 0123456
+test string-11.9.11.$noComp {string match} {
+ run {string match *3***\[4-6] 0123456}
} 1
-test string-11.10 {string match} {
- string match *3*6*9 01234567890
+test string-11.10.$noComp {string match} {
+ run {string match *3*6*9 01234567890}
} 0
-test string-11.10.1 {string match} {
- string match *3*6*89 01234567890
+test string-11.10.1.$noComp {string match} {
+ run {string match *3*6*89 01234567890}
} 0
-test string-11.10.2 {string match} {
- string match *3*456*89 01234567890
+test string-11.10.2.$noComp {string match} {
+ run {string match *3*456*89 01234567890}
} 0
-test string-11.10.3 {string match} {
- string match **3*456*89 01234567890
+test string-11.10.3.$noComp {string match} {
+ run {string match **3*456*89 01234567890}
} 0
-test string-11.10.4 {string match} {
- string match *3*456***89 01234567890
+test string-11.10.4.$noComp {string match} {
+ run {string match *3*456***89 01234567890}
} 0
-test string-11.11 {string match} {
- string match a?c abc
+test string-11.11.$noComp {string match} {
+ run {string match a?c abc}
} 1
-test string-11.12 {string match} {
- string match a??c abc
+test string-11.12.$noComp {string match} {
+ run {string match a??c abc}
} 0
-test string-11.13 {string match} {
- string match ?1??4???8? 0123456789
+test string-11.13.$noComp {string match} {
+ run {string match ?1??4???8? 0123456789}
} 1
-test string-11.14 {string match} {
- string match {[abc]bc} abc
+test string-11.14.$noComp {string match} {
+ run {string match {[abc]bc} abc}
} 1
-test string-11.15 {string match} {
- string match {a[abc]c} abc
+test string-11.15.$noComp {string match} {
+ run {string match {a[abc]c} abc}
} 1
-test string-11.16 {string match} {
- string match {a[xyz]c} abc
+test string-11.16.$noComp {string match} {
+ run {string match {a[xyz]c} abc}
} 0
-test string-11.17 {string match} {
- string match {12[2-7]45} 12345
+test string-11.17.$noComp {string match} {
+ run {string match {12[2-7]45} 12345}
} 1
-test string-11.18 {string match} {
- string match {12[ab2-4cd]45} 12345
+test string-11.18.$noComp {string match} {
+ run {string match {12[ab2-4cd]45} 12345}
} 1
-test string-11.19 {string match} {
- string match {12[ab2-4cd]45} 12b45
+test string-11.19.$noComp {string match} {
+ run {string match {12[ab2-4cd]45} 12b45}
} 1
-test string-11.20 {string match} {
- string match {12[ab2-4cd]45} 12d45
+test string-11.20.$noComp {string match} {
+ run {string match {12[ab2-4cd]45} 12d45}
} 1
-test string-11.21 {string match} {
- string match {12[ab2-4cd]45} 12145
+test string-11.21.$noComp {string match} {
+ run {string match {12[ab2-4cd]45} 12145}
} 0
-test string-11.22 {string match} {
- string match {12[ab2-4cd]45} 12545
+test string-11.22.$noComp {string match} {
+ run {string match {12[ab2-4cd]45} 12545}
} 0
-test string-11.23 {string match} {
- string match {a\*b} a*b
+test string-11.23.$noComp {string match} {
+ run {string match {a\*b} a*b}
} 1
-test string-11.24 {string match} {
- string match {a\*b} ab
+test string-11.24.$noComp {string match} {
+ run {string match {a\*b} ab}
} 0
-test string-11.25 {string match} {
- string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
+test string-11.25.$noComp {string match} {
+ run {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"}
} 1
-test string-11.26 {string match} {
- string match ** ""
+test string-11.26.$noComp {string match} {
+ run {string match ** ""}
} 1
-test string-11.27 {string match} {
- string match *. ""
+test string-11.27.$noComp {string match} {
+ run {string match *. ""}
} 0
-test string-11.28 {string match} {
- string match "" ""
+test string-11.28.$noComp {string match} {
+ run {string match "" ""}
} 1
-test string-11.29 {string match} {
- string match \[a a
+test string-11.29.$noComp {string match} {
+ run {string match \[a a}
} 1
-test string-11.30 {string match, bad args} {
- list [catch {string match - b c} msg] $msg
+test string-11.30.$noComp {string match, bad args} {
+ list [catch {run {string match - b c}} msg] $msg
} {1 {bad option "-": must be -nocase}}
-test string-11.31 {string match case} {
- string match a A
+test string-11.31.$noComp {string match case} {
+ run {string match a A}
} 0
-test string-11.32 {string match nocase} {
- string match -n a A
+test string-11.32.$noComp {string match nocase} {
+ run {string match -n a A}
} 1
-test string-11.33 {string match nocase} {
- string match -nocase a\334 A\374
+test string-11.33.$noComp {string match nocase} {
+ run {string match -nocase a\334 A\374}
} 1
-test string-11.34 {string match nocase} {
- string match -nocase a*f ABCDEf
+test string-11.34.$noComp {string match nocase} {
+ run {string match -nocase a*f ABCDEf}
} 1
-test string-11.35 {string match case, false hope} {
+test string-11.35.$noComp {string match case, false hope} {
# This is true because '_' lies between the A-Z and a-z ranges
- string match {[A-z]} _
+ run {string match {[A-z]} _}
} 1
-test string-11.36 {string match nocase range} {
+test string-11.36.$noComp {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.
- string match -nocase {[A-z]} _
+ run {string match -nocase {[A-z]} _}
} 0
-test string-11.37 {string match nocase} {
- string match -nocase {[A-fh-Z]} g
+test string-11.37.$noComp {string match nocase} {
+ run {string match -nocase {[A-fh-Z]} g}
} 0
-test string-11.38 {string match case, reverse range} {
- string match {[A-fh-Z]} g
+test string-11.38.$noComp {string match case, reverse range} {
+ run {string match {[A-fh-Z]} g}
} 1
-test string-11.39 {string match, *\ case} {
- string match {*\abc} abc
+test string-11.39.$noComp {string match, *\ case} {
+ run {string match {*\abc} abc}
} 1
-test string-11.39.1 {string match, *\ case} {
- string match {*ab\c} abc
+test string-11.39.1.$noComp {string match, *\ case} {
+ run {string match {*ab\c} abc}
} 1
-test string-11.39.2 {string match, *\ case} {
- string match {*ab\*} ab*
+test string-11.39.2.$noComp {string match, *\ case} {
+ run {string match {*ab\*} ab*}
} 1
-test string-11.39.3 {string match, *\ case} {
- string match {*ab\*} abc
+test string-11.39.3.$noComp {string match, *\ case} {
+ run {string match {*ab\*} abc}
} 0
-test string-11.39.4 {string match, *\ case} {
- string match {*ab\\*} {ab\c}
+test string-11.39.4.$noComp {string match, *\ case} {
+ run {string match {*ab\\*} {ab\c}}
} 1
-test string-11.39.5 {string match, *\ case} {
- string match {*ab\\*} {ab\*}
+test string-11.39.5.$noComp {string match, *\ case} {
+ run {string match {*ab\\*} {ab\*}}
} 1
-test string-11.40 {string match, *special case} {
- string match {*[ab]} abc
+test string-11.40.$noComp {string match, *special case} {
+ run {string match {*[ab]} abc}
} 0
-test string-11.41 {string match, *special case} {
- string match {*[ab]*} abc
+test string-11.41.$noComp {string match, *special case} {
+ run {string match {*[ab]*} abc}
} 1
-test string-11.42 {string match, *special case} {
- string match "*\\" "\\"
+test string-11.42.$noComp {string match, *special case} {
+ run {string match "*\\" "\\"}
} 0
-test string-11.43 {string match, *special case} {
- string match "*\\\\" "\\"
+test string-11.43.$noComp {string match, *special case} {
+ run {string match "*\\\\" "\\"}
} 1
-test string-11.44 {string match, *special case} {
- string match "*???" "12345"
+test string-11.44.$noComp {string match, *special case} {
+ run {string match "*???" "12345"}
} 1
-test string-11.45 {string match, *special case} {
- string match "*???" "12"
+test string-11.45.$noComp {string match, *special case} {
+ run {string match "*???" "12"}
} 0
-test string-11.46 {string match, *special case} {
- string match "*\\*" "abc*"
+test string-11.46.$noComp {string match, *special case} {
+ run {string match "*\\*" "abc*"}
} 1
-test string-11.47 {string match, *special case} {
- string match "*\\*" "*"
+test string-11.47.$noComp {string match, *special case} {
+ run {string match "*\\*" "*"}
} 1
-test string-11.48 {string match, *special case} {
- string match "*\\*" "*abc"
+test string-11.48.$noComp {string match, *special case} {
+ run {string match "*\\*" "*abc"}
} 0
-test string-11.49 {string match, *special case} {
- string match "?\\*" "a*"
+test string-11.49.$noComp {string match, *special case} {
+ run {string match "?\\*" "a*"}
} 1
-test string-11.50 {string match, *special case} {
- string match "\\" "\\"
+test string-11.50.$noComp {string match, *special case} {
+ run {string match "\\" "\\"}
} 0
-test string-11.51 {string match; *, -nocase and UTF-8} {
- string match -nocase [binary format I 717316707] \
- [binary format I 2028036707]
+test string-11.51.$noComp {string match; *, -nocase and UTF-8} {
+ run {string match -nocase [binary format I 717316707] \
+ [binary format I 2028036707]}
} 1
-test string-11.52 {string match, null char in string} {
+test string-11.52.$noComp {string match, null char in string} {
set out ""
set ptn "*abc*"
- foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] {
- lappend out [string match $ptn $elem]
+ foreach elem [list "\x00@abc" "@abc" "\x00@abc\x00" "blahabcblah"] {
+ lappend out [run {string match $ptn $elem}]
}
set out
} {1 1 1 1}
-test string-11.53 {string match, null char in pattern} {
+test string-11.53.$noComp {string match, null char in pattern} {
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" \
+ "*\x00abc\x00" "\x00abc\x00" \
+ "*\x00abc\x00" "\x00abc\x00ef" \
+ "*\x00abc\x00*" "\x00abc\x00ef" \
+ "*\x00abc\x00" "@\x00abc\x00ef" \
+ "*\x00abc\x00*" "@\x00abc\x00ef" \
] {
- lappend out [string match $ptn $elem]
+ lappend out [run {string match $ptn $elem}]
}
set out
} {1 0 1 0 1}
-test string-11.54 {string match, failure} {
+test string-11.54.$noComp {string match, failure} {
set longString ""
for {set i 0} {$i < 10} {incr i} {
- append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123"
+ append longString "abcdefghijklmnopqrstuvwxy\x00z01234567890123"
}
- string first $longString 123
- 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]
+ run {string first $longString 123}
+ list [run {string match *cba* $longString}] \
+ [run {string match *a*l*\x00* $longString}] \
+ [run {string match *a*l*\x00*123 $longString}] \
+ [run {string match *a*l*\x00*123* $longString}] \
+ [run {string match *a*l*\x00*cba* $longString}] \
+ [run {string match *===* $longString}]
} {0 1 1 1 0 0}
-test string-11.55 {string match, invalid binary optimization} {
+test string-11.55.$noComp {string match, invalid binary optimization} {
[format string] match \u0141 [binary format c 65]
} 0
-test string-12.1 {string range} {
- list [catch {string range} msg] $msg
+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"}}
-test string-12.2 {string range} {
- list [catch {string range a 1} msg] $msg
+test string-12.2.$noComp {string range} {
+ list [catch {run {string range a 1}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
-test string-12.3 {string range} {
- list [catch {string range a 1 2 3} msg] $msg
+test string-12.3.$noComp {string range} {
+ list [catch {run {string range a 1 2 3}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
-test string-12.4 {string range} {
- string range abcdefghijklmnop 2 14
+test string-12.4.$noComp {string range} {
+ run {string range abcdefghijklmnop 2 14}
} {cdefghijklmno}
-test string-12.5 {string range, last > length} {
- string range abcdefghijklmnop 7 1000
+test string-12.5.$noComp {string range, last > length} {
+ run {string range abcdefghijklmnop 7 1000}
} {hijklmnop}
-test string-12.6 {string range} {
- string range abcdefghijklmnop 10 end
+test string-12.6.$noComp {string range} {
+ run {string range abcdefghijklmnop 10 end}
} {klmnop}
-test string-12.7 {string range, last < first} {
- string range abcdefghijklmnop 10 9
+test string-12.7.$noComp {string range, last < first} {
+ run {string range abcdefghijklmnop 10 9}
} {}
-test string-12.8 {string range, first < 0} {
- string range abcdefghijklmnop -3 2
+test string-12.8.$noComp {string range, first < 0} {
+ run {string range abcdefghijklmnop -3 2}
} {abc}
-test string-12.9 {string range} {
- string range abcdefghijklmnop -3 -2
+test string-12.9.$noComp {string range} {
+ run {string range abcdefghijklmnop -3 -2}
} {}
-test string-12.10 {string range} {
- string range abcdefghijklmnop 1000 1010
+test string-12.10.$noComp {string range} {
+ run {string range abcdefghijklmnop 1000 1010}
} {}
-test string-12.11 {string range} {
- string range abcdefghijklmnop -100 end
+test string-12.11.$noComp {string range} {
+ run {string range abcdefghijklmnop -100 end}
} {abcdefghijklmnop}
-test string-12.12 {string range} {
- list [catch {string range abc abc 1} msg] $msg
+test string-12.12.$noComp {string range} {
+ list [catch {run {string range abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-12.13 {string range} {
- list [catch {string range abc 1 eof} msg] $msg
+test string-12.13.$noComp {string range} {
+ list [catch {run {string range abc 1 eof}} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-12.14 {string range} {
- string range abcdefghijklmnop end-1 end
+test string-12.14.$noComp {string range} {
+ run {string range abcdefghijklmnop end-1 end}
} {op}
-test string-12.15 {string range} {
- string range abcdefghijklmnop end 1000
+test string-12.15.$noComp {string range} {
+ run {string range abcdefghijklmnop end 1000}
} {p}
-test string-12.16 {string range} {
- string range abcdefghijklmnop end end-1
+test string-12.16.$noComp {string range} {
+ run {string range abcdefghijklmnop end end-1}
} {}
-test string-12.17 {string range, unicode} {
- string range ab\u7266cdefghijklmnop 5 5
+test string-12.17.$noComp {string range, unicode} {
+ run {string range ab\u7266cdefghijklmnop 5 5}
} e
-test string-12.18 {string range, unicode} {
- string range ab\u7266cdefghijklmnop 2 3
+test string-12.18.$noComp {string range, unicode} {
+ run {string range ab\u7266cdefghijklmnop 2 3}
} \u7266c
-test string-12.19 {string range, bytearray object} {
+test string-12.19.$noComp {string range, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
- set r1 [string range $b 1 end-1]
- set r2 [string range $b 1 6]
- string equal $r1 $r2
+ set r1 [run {string range $b 1 end-1}]
+ set r2 [run {string range $b 1 6}]
+ run {string equal $r1 $r2}
} 1
-test string-12.20 {string range, out of bounds indices} {
- string range \u00FF 0 1
-} \u00FF
+test string-12.20.$noComp {string range, out of bounds indices} {
+ run {string range \xFF 0 1}
+} \xFF
# Bug 1410553
-test string-12.21 {string range, regenerates correct reps, bug 1410553} {
+test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} {
set bytes "\x00 \x03 \x41"
set rxBuffer {}
foreach ch $bytes {
append rxBuffer $ch
if {$ch eq "\x03"} {
- string length $rxBuffer
+ run {string length $rxBuffer}
}
}
- set rxCRC [string range $rxBuffer end-1 end]
+ set rxCRC [run {string range $rxBuffer end-1 end}]
binary scan [join $bytes {}] "H*" input_hex
binary scan $rxBuffer "H*" rxBuffer_hex
binary scan $rxCRC "H*" rxCRC_hex
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
-test string-12.22 {string range, shimmering binary/index} {
+test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
- string range $s $s end
+ run {string range $s $s end}
} 000000001
-test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} utf16 {
- list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
+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-13.1 {string repeat} {
- list [catch {string repeat} msg] $msg
+test string-13.1.$noComp {string repeat} {
+ list [catch {run {string repeat}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
-test string-13.2 {string repeat} {
- list [catch {string repeat abc 10 oops} msg] $msg
+test string-13.2.$noComp {string repeat} {
+ list [catch {run {string repeat abc 10 oops}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
-test string-13.3 {string repeat} {
- string repeat {} 100
+test string-13.3.$noComp {string repeat} {
+ run {string repeat {} 100}
} {}
-test string-13.4 {string repeat} {
- string repeat { } 5
+test string-13.4.$noComp {string repeat} {
+ run {string repeat { } 5}
} { }
-test string-13.5 {string repeat} {
- string repeat abc 3
+test string-13.5.$noComp {string repeat} {
+ run {string repeat abc 3}
} {abcabcabc}
-test string-13.6 {string repeat} {
- string repeat abc -1
+test string-13.6.$noComp {string repeat} {
+ run {string repeat abc -1}
} {}
-test string-13.7 {string repeat} {
- list [catch {string repeat abc end} msg] $msg
+test string-13.7.$noComp {string repeat} {
+ list [catch {run {string repeat abc end}} msg] $msg
} {1 {expected integer but got "end"}}
-test string-13.8 {string repeat} {
- string repeat {} -1000
+test string-13.8.$noComp {string repeat} {
+ run {string repeat {} -1000}
} {}
-test string-13.9 {string repeat} {
- string repeat {} 0
+test string-13.9.$noComp {string repeat} {
+ run {string repeat {} 0}
} {}
-test string-13.10 {string repeat} {
- string repeat def 0
+test string-13.10.$noComp {string repeat} {
+ run {string repeat def 0}
} {}
-test string-13.11 {string repeat} {
- string repeat def 1
+test string-13.11.$noComp {string repeat} {
+ run {string repeat def 1}
} def
-test string-13.12 {string repeat} {
- string repeat ab\u7266cd 3
+test string-13.12.$noComp {string repeat} {
+ run {string repeat ab\u7266cd 3}
} ab\u7266cdab\u7266cdab\u7266cd
-test string-13.13 {string repeat} {
- string repeat \x00 3
+test string-13.13.$noComp {string repeat} {
+ run {string repeat \x00 3}
} \x00\x00\x00
-test string-13.14 {string repeat} {
+test string-13.14.$noComp {string repeat} {
# The string range will ensure us that string repeat gets a unicode string
- string repeat [string range ab\u7266cd 2 3] 3
+ run {string repeat [run {string range ab\u7266cd 2 3}] 3}
} \u7266c\u7266c\u7266c
-test string-14.1 {string replace} {
- list [catch {string replace} msg] $msg
+test string-14.1.$noComp {string replace} {
+ list [catch {run {string replace}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
-test string-14.2 {string replace} {
- list [catch {string replace a 1} msg] $msg
+test string-14.2.$noComp {string replace} {
+ list [catch {run {string replace a 1}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
-test string-14.3 {string replace} {
- list [catch {string replace a 1 2 3 4} msg] $msg
+test string-14.3.$noComp {string replace} {
+ list [catch {run {string replace a 1 2 3 4}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
-test string-14.4 {string replace} {
+test string-14.4.$noComp {string replace} {
} {}
-test string-14.5 {string replace} {
- string replace abcdefghijklmnop 2 14
+test string-14.5.$noComp {string replace} {
+ run {string replace abcdefghijklmnop 2 14}
} {abp}
-test string-14.6 {string replace} {
- string replace abcdefghijklmnop 7 1000
-} {abcdefg}
-test string-14.7 {string replace} {
- string replace abcdefghijklmnop 10 end
+test string-14.6.$noComp {string replace} -body {
+ run {string replace abcdefghijklmnop 7 1000}
+} -result {abcdefg}
+test string-14.7.$noComp {string replace} {
+ run {string replace abcdefghijklmnop 10 end}
} {abcdefghij}
-test string-14.8 {string replace} {
- string replace abcdefghijklmnop 10 9
+test string-14.8.$noComp {string replace} {
+ run {string replace abcdefghijklmnop 10 9}
} {abcdefghijklmnop}
-test string-14.9 {string replace} {
- string replace abcdefghijklmnop -3 2
+test string-14.9.$noComp {string replace} {
+ run {string replace abcdefghijklmnop -3 2}
} {defghijklmnop}
-test string-14.10 {string replace} {
- string replace abcdefghijklmnop -3 -2
-} {abcdefghijklmnop}
-test string-14.11 {string replace} {
- string replace abcdefghijklmnop 1000 1010
+test string-14.10.$noComp {string replace} {
+ run {string replace abcdefghijklmnop -3 -2}
} {abcdefghijklmnop}
-test string-14.12 {string replace} {
- string replace abcdefghijklmnop -100 end
+test string-14.11.$noComp {string replace} -body {
+ run {string replace abcdefghijklmnop 1000 1010}
+} -result {abcdefghijklmnop}
+test string-14.12.$noComp {string replace} {
+ run {string replace abcdefghijklmnop -100 end}
} {}
-test string-14.13 {string replace} {
- list [catch {string replace abc abc 1} msg] $msg
+test string-14.13.$noComp {string replace} {
+ list [catch {run {string replace abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-14.14 {string replace} {
- list [catch {string replace abc 1 eof} msg] $msg
+test string-14.14.$noComp {string replace} {
+ list [catch {run {string replace abc 1 eof}} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-14.15 {string replace} {
- string replace abcdefghijklmnop end-10 end-2 NEW
+test string-14.15.$noComp {string replace} {
+ run {string replace abcdefghijklmnop end-10 end-2 NEW}
} {abcdeNEWop}
-test string-14.16 {string replace} {
- string replace abcdefghijklmnop 0 end foo
+test string-14.16.$noComp {string replace} {
+ run {string replace abcdefghijklmnop 0 end foo}
} {foo}
-test string-14.17 {string replace} {
- string replace abcdefghijklmnop end end-1
+test string-14.17.$noComp {string replace} {
+ run {string replace abcdefghijklmnop end end-1}
} {abcdefghijklmnop}
-test string-14.18 {string replace} {
- string replace abcdefghijklmnop 10 9 XXX
+test string-14.18.$noComp {string replace} {
+ run {string replace abcdefghijklmnop 10 9 XXX}
} {abcdefghijklmnop}
-test string-14.19 {string replace} {
- string replace {} -1 0 A
+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 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 string-15.1 {string tolower too few args} {
- list [catch {string tolower} msg] $msg
+test string-15.1.$noComp {string tolower too few args} {
+ list [catch {run {string tolower}} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
-test string-15.2 {string tolower bad args} {
- list [catch {string tolower a b} msg] $msg
+test string-15.2.$noComp {string tolower bad args} {
+ list [catch {run {string tolower a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-15.3 {string tolower too many args} {
- list [catch {string tolower ABC 1 end oops} msg] $msg
+test string-15.3.$noComp {string tolower too many args} {
+ list [catch {run {string tolower ABC 1 end oops}} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
-test string-15.4 {string tolower} {
- string tolower ABCDeF
+test string-15.4.$noComp {string tolower} {
+ run {string tolower ABCDeF}
} {abcdef}
-test string-15.5 {string tolower} {
- string tolower "ABC XyZ"
+test string-15.5.$noComp {string tolower} {
+ run {string tolower "ABC XyZ"}
} {abc xyz}
-test string-15.6 {string tolower} {
- string tolower {123#$&*()}
+test string-15.6.$noComp {string tolower} {
+ run {string tolower {123#$&*()}}
} {123#$&*()}
-test string-15.7 {string tolower} {
- string tolower ABC 1
+test string-15.7.$noComp {string tolower} {
+ run {string tolower ABC 1}
} AbC
-test string-15.8 {string tolower} {
- string tolower ABC 1 end
+test string-15.8.$noComp {string tolower} {
+ run {string tolower ABC 1 end}
} Abc
-test string-15.9 {string tolower} {
- string tolower ABC 0 end-1
+test string-15.9.$noComp {string tolower} {
+ run {string tolower ABC 0 end-1}
} abC
-test string-15.10 {string tolower, unicode} {
- string tolower ABCabc\xc7\xe7
-} "abcabc\xe7\xe7"
-test string-15.11 {string tolower, compiled} {
- lindex [string tolower [list A B [list C]]] 1
+test string-15.10.$noComp {string tolower, unicode} {
+ run {string tolower ABCabc\xC7\xE7}
+} "abcabc\xE7\xE7"
+test string-15.11.$noComp {string tolower, compiled} {
+ lindex [run {string tolower [list A B [list C]]}] 1
} b
-test string-16.1 {string toupper} {
- list [catch {string toupper} msg] $msg
+test string-16.1.$noComp {string toupper} {
+ list [catch {run {string toupper}} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
-test string-16.2 {string toupper} {
- list [catch {string toupper a b} msg] $msg
+test string-16.2.$noComp {string toupper} {
+ list [catch {run {string toupper a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-16.3 {string toupper} {
- list [catch {string toupper a 1 end oops} msg] $msg
+test string-16.3.$noComp {string toupper} {
+ list [catch {run {string toupper a 1 end oops}} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
-test string-16.4 {string toupper} {
- string toupper abCDEf
+test string-16.4.$noComp {string toupper} {
+ run {string toupper abCDEf}
} {ABCDEF}
-test string-16.5 {string toupper} {
- string toupper "abc xYz"
+test string-16.5.$noComp {string toupper} {
+ run {string toupper "abc xYz"}
} {ABC XYZ}
-test string-16.6 {string toupper} {
- string toupper {123#$&*()}
+test string-16.6.$noComp {string toupper} {
+ run {string toupper {123#$&*()}}
} {123#$&*()}
-test string-16.7 {string toupper} {
- string toupper abc 1
+test string-16.7.$noComp {string toupper} {
+ run {string toupper abc 1}
} aBc
-test string-16.8 {string toupper} {
- string toupper abc 1 end
+test string-16.8.$noComp {string toupper} {
+ run {string toupper abc 1 end}
} aBC
-test string-16.9 {string toupper} {
- string toupper abc 0 end-1
+test string-16.9.$noComp {string toupper} {
+ run {string toupper abc 0 end-1}
} ABc
-test string-16.10 {string toupper, unicode} {
- string toupper ABCabc\xc7\xe7
-} "ABCABC\xc7\xc7"
-test string-16.11 {string toupper, compiled} {
- lindex [string toupper [list a b [list c]]] 1
+test string-16.10.$noComp {string toupper, unicode} {
+ run {string toupper ABCabc\xC7\xE7}
+} "ABCABC\xC7\xC7"
+test string-16.11.$noComp {string toupper, compiled} {
+ lindex [run {string toupper [list a b [list c]]}] 1
} B
-test string-17.1 {string totitle} {
- list [catch {string totitle} msg] $msg
+test string-17.1.$noComp {string totitle} {
+ list [catch {run {string totitle}} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
-test string-17.2 {string totitle} {
- list [catch {string totitle a b} msg] $msg
+test string-17.2.$noComp {string totitle} {
+ list [catch {run {string totitle a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-17.3 {string totitle} {
- string totitle abCDEf
+test string-17.3.$noComp {string totitle} {
+ run {string totitle abCDEf}
} {Abcdef}
-test string-17.4 {string totitle} {
- string totitle "abc xYz"
+test string-17.4.$noComp {string totitle} {
+ run {string totitle "abc xYz"}
} {Abc xyz}
-test string-17.5 {string totitle} {
- string totitle {123#$&*()}
+test string-17.5.$noComp {string totitle} {
+ run {string totitle {123#$&*()}}
} {123#$&*()}
-test string-17.6 {string totitle, unicode} {
- string totitle ABCabc\xC7\xE7
+test string-17.6.$noComp {string totitle, unicode} {
+ run {string totitle ABCabc\xC7\xE7}
} "Abcabc\xE7\xE7"
-test string-17.7 {string totitle, unicode} {
- string totitle \u01F3BCabc\xc7\xe7
-} "\u01F2bcabc\xe7\xe7"
-test string-17.8 {string totitle, compiled} {
- lindex [string totitle [list aa bb [list cc]]] 0
+test string-17.7.$noComp {string totitle, unicode} {
+ run {string totitle \u01F3BCabc\xC7\xE7}
+} "\u01F2bcabc\xE7\xE7"
+test string-17.8.$noComp {string totitle, compiled} {
+ lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
+test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} 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 {string trim} {
- list [catch {string trim} msg] $msg
+test string-18.1.$noComp {string trim} {
+ list [catch {run {string trim}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
-test string-18.2 {string trim} {
- list [catch {string trim a b c} msg] $msg
+test string-18.2.$noComp {string trim} {
+ list [catch {run {string trim a b c}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
-test string-18.3 {string trim} {
- string trim " XYZ "
+test string-18.3.$noComp {string trim} {
+ run {string trim " XYZ "}
} {XYZ}
-test string-18.4 {string trim} {
- string trim "\t\nXYZ\t\n\r\n"
+test string-18.4.$noComp {string trim} {
+ run {string trim "\t\nXYZ\t\n\r\n"}
} {XYZ}
-test string-18.5 {string trim} {
- string trim " A XYZ A "
+test string-18.5.$noComp {string trim} {
+ run {string trim " A XYZ A "}
} {A XYZ A}
-test string-18.6 {string trim} {
- string trim "XXYYZZABC XXYYZZ" ZYX
+test string-18.6.$noComp {string trim} {
+ run {string trim "XXYYZZABC XXYYZZ" ZYX}
} {ABC }
-test string-18.7 {string trim} {
- string trim " \t\r "
+test string-18.7.$noComp {string trim} {
+ run {string trim " \t\r "}
} {}
-test string-18.8 {string trim} {
- string trim {abcdefg} {}
+test string-18.8.$noComp {string trim} {
+ run {string trim {abcdefg} {}}
} {abcdefg}
-test string-18.9 {string trim} {
- string trim {}
+test string-18.9.$noComp {string trim} {
+ run {string trim {}}
} {}
-test string-18.10 {string trim} {
- string trim ABC DEF
+test string-18.10.$noComp {string trim} {
+ run {string trim ABC DEF}
} {ABC}
-test string-18.11 {string trim, unicode} {
- string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8
-} " AB\xe7C "
-test string-18.12 {string trim, unicode default} {
- string trim \uFEFF\x00\u0085\u00A0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000
+test string-18.11.$noComp {string trim, unicode} {
+ run {string trim "\xE7\xE8 AB\xE7C \xE8\xE7" \xE7\xE8}
+} " AB\xE7C "
+test string-18.12.$noComp {string trim, unicode default} {
+ run {string trim \uFEFF\x00\x85\xA0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
-test string-19.1 {string trimleft} {
- list [catch {string trimleft} msg] $msg
+test string-19.1.$noComp {string trimleft} {
+ list [catch {run {string trimleft}} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
-test string-19.2 {string trimleft} {
- string trimleft " XYZ "
+test string-19.2.$noComp {string trimleft} {
+ run {string trimleft " XYZ "}
} {XYZ }
-test string-19.3 {string trimleft, unicode default} {
- string trimleft \uFEFF\u0085\u00A0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC
+test string-19.3.$noComp {string trimleft, unicode default} {
+ run {string trimleft \uFEFF\x85\xA0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC}
} \u1361ABC
-test string-20.1 {string trimright errors} {
- list [catch {string trimright} msg] $msg
+test string-20.1.$noComp {string trimright errors} {
+ list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
-test string-20.2 {string trimright errors} {
- list [catch {string trimg a} msg] $msg
-} {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}}
-test string-20.3 {string trimright} {
- string trimright " XYZ "
+test string-20.2.$noComp {string trimright errors} {
+ list [catch {run {string trimg a}} msg] $msg
+} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, 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}
-test string-20.4 {string trimright} {
- string trimright " "
+test string-20.4.$noComp {string trimright} {
+ run {string trimright " "}
} {}
-test string-20.5 {string trimright} {
- string trimright ""
+test string-20.5.$noComp {string trimright} {
+ run {string trimright ""}
} {}
-test string-20.6 {string trimright, unicode default} {
- string trimright ABC\u1361\u0085\x00\u00A0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000
+test string-20.6.$noComp {string trimright, unicode default} {
+ run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
-test string-20.7 {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} testbytestring {
+test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} {testbytestring} {
set result {}
- set a [testbytestring \xc0\x80\xA0]
+ set a [testbytestring \xC0\x80\xA0]
set b foo$a
- set m [list \u0000 U \xA0 V [testbytestring \xA0] W]
+ set m [list \x00 U \xA0 V [testbytestring \xA0] W]
lappend result [string map $m $b]
- lappend result [string map $m [string trimright $b x]]
- lappend result [string map $m [string trimright $b \u0000]]
- lappend result [string map $m [string trimleft $b fox]]
- lappend result [string map $m [string trimleft $b fo\u0000]]
- lappend result [string map $m [string trim $b fox]]
- lappend result [string map $m [string trim $b fo\u0000]]
+ lappend result [string map $m [run {string trimright $b x}]]
+ lappend result [string map $m [run {string trimright $b \x00}]]
+ lappend result [string map $m [run {string trimleft $b fox}]]
+ lappend result [string map $m [run {string trimleft $b fo\x00}]]
+ lappend result [string map $m [run {string trim $b fox}]]
+ lappend result [string map $m [run {string trim $b fo\x00}]]
} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]]
-test string-20.8 {[c61818e4c9] [string trimright] fails when UtfPrev is ok} testbytestring {
+test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} {testbytestring} {
set result {}
set a [testbytestring \xE8\xA0]
set b foo$a
set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]]
lappend result [string map $m $b]
- lappend result [string map $m [string trimright $b x]]
- lappend result [string map $m [string trimright $b \xE8]]
- lappend result [string map $m [string trimright $b [bytestring \xE8]]]
- lappend result [string map $m [string trimright $b \xA0]]
- lappend result [string map $m [string trimright $b [bytestring \xA0]]]
- lappend result [string map $m [string trimright $b \xE8\xA0]]
- lappend result [string map $m [string trimright $b [bytestring \xE8\xA0]]]
- lappend result [string map $m [string trimright $b \u0000]]
+ 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 [testbytestring \xE8]}]]
+ lappend result [string map $m [run {string trimright $b \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 [testbytestring \xE8\xA0]}]]
+ lappend result [string map $m [run {string trimright $b \u0000}]]
} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV]
-test string-21.1 {string wordend} {
- list [catch {string wordend a} msg] $msg
-} {1 {wrong # args: should be "string wordend string index"}}
-test string-21.2 {string wordend} {
- list [catch {string wordend a b c} msg] $msg
-} {1 {wrong # args: should be "string wordend string index"}}
-test string-21.3 {string wordend} {
- list [catch {string wordend a gorp} msg] $msg
-} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-21.4 {string wordend} {
- string wordend abc. -1
-} 3
-test string-21.5 {string wordend} {
- string wordend abc. 100
-} 4
-test string-21.6 {string wordend} {
- string wordend "word_one two three" 2
-} 8
-test string-21.7 {string wordend} {
- string wordend "one .&# three" 5
-} 6
-test string-21.8 {string wordend} {
- string worde "x.y" 0
-} 1
-test string-21.9 {string wordend} {
- string worde "x.y" end-1
-} 2
-test string-21.10 {string wordend, unicode} {
- string wordend "xyz\u00C7de fg" 0
-} 6
-test string-21.11 {string wordend, unicode} {
- string wordend "xyz\uC700de fg" 0
-} 6
-test string-21.12 {string wordend, unicode} {
- string wordend "xyz\u203Fde fg" 0
-} 6
-test string-21.13 {string wordend, unicode} {
- string wordend "xyz\u2045de fg" 0
-} 3
-test string-21.14 {string wordend, unicode} {
- string wordend "\uC700\uC700 abc" 8
-} 6
+test string-21.1.$noComp {string wordend} -body {
+ list [catch {run {string wordend a}} msg] $msg
+} -result {1 {wrong # args: should be "string wordend string index"}}
+test string-21.2.$noComp {string wordend} -body {
+ list [catch {run {string wordend a b c}} msg] $msg
+} -result {1 {wrong # args: should be "string wordend string index"}}
+test string-21.3.$noComp {string wordend} -body {
+ list [catch {run {string wordend a gorp}} msg] $msg
+} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
+test string-21.4.$noComp {string wordend} -body {
+ run {string wordend abc. -1}
+} -result 3
+test string-21.5.$noComp {string wordend} -body {
+ run {string wordend abc. 100}
+} -result 4
+test string-21.6.$noComp {string wordend} -body {
+ run {string wordend "word_one two three" 2}
+} -result 8
+test string-21.7.$noComp {string wordend} -body {
+ run {string wordend "one .&# three" 5}
+} -result 6
+test string-21.8.$noComp {string wordend} -body {
+ run {string worde "x.y" 0}
+} -result 1
+test string-21.9.$noComp {string wordend} -body {
+ run {string worde "x.y" end-1}
+} -result 2
+test string-21.10.$noComp {string wordend, unicode} -body {
+ run {string wordend "xyz\xC7de fg" 0}
+} -result 6
+test string-21.11.$noComp {string wordend, unicode} -body {
+ run {string wordend "xyz\uC700de fg" 0}
+} -result 6
+test string-21.12.$noComp {string wordend, unicode} -body {
+ run {string wordend "xyz\u203Fde fg" 0}
+} -result 6
+test string-21.13.$noComp {string wordend, unicode} -body {
+ run {string wordend "xyz\u2045de fg" 0}
+} -result 3
+test string-21.14.$noComp {string wordend, unicode} -body {
+ run {string wordend "\uC700\uC700 abc" 8}
+} -result 6
+test string-21.15.$noComp {string wordend, unicode} -body {
+ run {string wordend "\U1D7CA\U1D7CA abc" 0}
+} -result 2
+test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body {
+ run {string wordend "\U1D7CA\U1D7CA abc" 10}
+} -result 8
-test string-22.1 {string wordstart} {
- list [catch {string word a} msg] $msg
-} {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}}
-test string-22.2 {string wordstart} {
- list [catch {string wordstart a} msg] $msg
-} {1 {wrong # args: should be "string wordstart string index"}}
-test string-22.3 {string wordstart} {
- list [catch {string wordstart a b c} msg] $msg
-} {1 {wrong # args: should be "string wordstart string index"}}
-test string-22.4 {string wordstart} {
- list [catch {string wordstart a gorp} msg] $msg
-} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
-test string-22.5 {string wordstart} {
- string wordstart "one two three_words" 400
-} 8
-test string-22.6 {string wordstart} {
- string wordstart "one two three_words" 2
-} 0
-test string-22.7 {string wordstart} {
- string wordstart "one two three_words" -2
-} 0
-test string-22.8 {string wordstart} {
- string wordstart "one .*&^ three" 6
-} 6
-test string-22.9 {string wordstart} {
- string wordstart "one two three" 4
-} 4
-test string-22.10 {string wordstart} {
- string wordstart "one two three" end-5
-} 7
-test string-22.11 {string wordstart, unicode} {
- string wordstart "one tw\u00C7o three" 7
-} 4
-test string-22.12 {string wordstart, unicode} {
- string wordstart "ab\uC700\uC700 cdef ghi" 12
-} 10
-test string-22.13 {string wordstart, unicode} {
- string wordstart "\uC700\uC700 abc" 8
-} 3
-test string-22.14 {string wordstart, invalid UTF-8} testbytestring {
+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, 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"}}
+test string-22.3.$noComp {string wordstart} -body {
+ list [catch {run {string wordstart a b c}} msg] $msg
+} -result {1 {wrong # args: should be "string wordstart string index"}}
+test string-22.4.$noComp {string wordstart} -body {
+ list [catch {run {string wordstart a gorp}} msg] $msg
+} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
+test string-22.5.$noComp {string wordstart} -body {
+ run {string wordstart "one two three_words" 400}
+} -result 8
+test string-22.6.$noComp {string wordstart} -body {
+ run {string wordstart "one two three_words" 2}
+} -result 0
+test string-22.7.$noComp {string wordstart} -body {
+ run {string wordstart "one two three_words" -2}
+} -result 0
+test string-22.8.$noComp {string wordstart} -body {
+ run {string wordstart "one .*&^ three" 6}
+} -result 6
+test string-22.9.$noComp {string wordstart} -body {
+ run {string wordstart "one two three" 4}
+} -result 4
+test string-22.10.$noComp {string wordstart} -body {
+ run {string wordstart "one two three" end-5}
+} -result 7
+test string-22.11.$noComp {string wordstart, unicode} -body {
+ run {string wordstart "one tw\xC7o three" 7}
+} -result 4
+test string-22.12.$noComp {string wordstart, unicode} -body {
+ run {string wordstart "ab\uC700\uC700 cdef ghi" 12}
+} -result 10
+test string-22.13.$noComp {string wordstart, unicode} -body {
+ run {string wordstart "\uC700\uC700 abc" 8}
+} -result 3
+test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbytestring -body {
# See Bug c61818e4c9
set demo [testbytestring "abc def\xE0\xA9ghi"]
- string index $demo [string wordstart $demo 10]
-} g
+ 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 {string is boolean, Bug 1187123} testindexobj {
+test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
- string is boolean $x
+ run {string is boolean $x}
} 0
-test string-23.1 {string is command with empty string} {
+test string-23.1.$noComp {string is command with empty string} {
set s ""
list \
- [string is alnum $s] \
- [string is alpha $s] \
- [string is ascii $s] \
- [string is control $s] \
- [string is boolean $s] \
- [string is digit $s] \
- [string is double $s] \
- [string is false $s] \
- [string is graph $s] \
- [string is integer $s] \
- [string is lower $s] \
- [string is print $s] \
- [string is punct $s] \
- [string is space $s] \
- [string is true $s] \
- [string is upper $s] \
- [string is wordchar $s] \
- [string is xdigit $s] \
+ [run {string is alnum $s}] \
+ [run {string is alpha $s}] \
+ [run {string is ascii $s}] \
+ [run {string is control $s}] \
+ [run {string is boolean $s}] \
+ [run {string is digit $s}] \
+ [run {string is double $s}] \
+ [run {string is false $s}] \
+ [run {string is graph $s}] \
+ [run {string is integer $s}] \
+ [run {string is lower $s}] \
+ [run {string is print $s}] \
+ [run {string is punct $s}] \
+ [run {string is space $s}] \
+ [run {string is true $s}] \
+ [run {string is upper $s}] \
+ [run {string is wordchar $s}] \
+ [run {string is xdigit $s}] \
} {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}
-test string-23.2 {string is command with empty string} {
+test string-23.2.$noComp {string is command with empty string} {
set s ""
list \
- [string is alnum -strict $s] \
- [string is alpha -strict $s] \
- [string is ascii -strict $s] \
- [string is control -strict $s] \
- [string is boolean -strict $s] \
- [string is digit -strict $s] \
- [string is double -strict $s] \
- [string is false -strict $s] \
- [string is graph -strict $s] \
- [string is integer -strict $s] \
- [string is lower -strict $s] \
- [string is print -strict $s] \
- [string is punct -strict $s] \
- [string is space -strict $s] \
- [string is true -strict $s] \
- [string is upper -strict $s] \
- [string is wordchar -strict $s] \
- [string is xdigit -strict $s] \
+ [run {string is alnum -strict $s}] \
+ [run {string is alpha -strict $s}] \
+ [run {string is ascii -strict $s}] \
+ [run {string is control -strict $s}] \
+ [run {string is boolean -strict $s}] \
+ [run {string is digit -strict $s}] \
+ [run {string is double -strict $s}] \
+ [run {string is false -strict $s}] \
+ [run {string is graph -strict $s}] \
+ [run {string is integer -strict $s}] \
+ [run {string is lower -strict $s}] \
+ [run {string is print -strict $s}] \
+ [run {string is punct -strict $s}] \
+ [run {string is space -strict $s}] \
+ [run {string is true -strict $s}] \
+ [run {string is upper -strict $s}] \
+ [run {string is wordchar -strict $s}] \
+ [run {string is xdigit -strict $s}] \
} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}
-test string-24.1 {string reverse command} -body {
- string reverse
+test string-24.1.$noComp {string reverse command} -body {
+ run {string reverse}
} -returnCodes error -result "wrong # args: should be \"string reverse string\""
-test string-24.2 {string reverse command} -body {
- string reverse a b
+test string-24.2.$noComp {string reverse command} -body {
+ run {string reverse a b}
} -returnCodes error -result "wrong # args: should be \"string reverse string\""
-test string-24.3 {string reverse command - shared string} {
+test string-24.3.$noComp {string reverse command - shared string} {
set x abcde
- string reverse $x
+ run {string reverse $x}
} edcba
-test string-24.4 {string reverse command - unshared string} {
+test string-24.4.$noComp {string reverse command - unshared string} {
set x abc
set y de
- string reverse $x$y
+ run {string reverse $x$y}
} edcba
-test string-24.5 {string reverse command - shared unicode string} {
+test string-24.5.$noComp {string reverse command - shared unicode string} {
set x abcde\uD0AD
- string reverse $x
+ run {string reverse $x}
} \uD0ADedcba
-test string-24.6 {string reverse command - unshared string} {
+test string-24.6.$noComp {string reverse command - unshared string} {
set x abc
set y de\uD0AD
- string reverse $x$y
+ run {string reverse $x$y}
} \uD0ADedcba
-test string-24.7 {string reverse command - simple case} {
- string reverse a
+test string-24.7.$noComp {string reverse command - simple case} {
+ run {string reverse a}
} a
-test string-24.8 {string reverse command - simple case} {
- string reverse \uD0AD
+test string-24.8.$noComp {string reverse command - simple case} {
+ run {string reverse \uD0AD}
} \uD0AD
-test string-24.9 {string reverse command - simple case} {
- string reverse {}
+test string-24.9.$noComp {string reverse command - simple case} {
+ run {string reverse {}}
} {}
-test string-24.10 {string reverse command - corner case} {
+test string-24.10.$noComp {string reverse command - corner case} {
set x \uBEEF\uD0AD
- string reverse $x
+ run {string reverse $x}
} \uD0AD\uBEEF
-test string-24.11 {string reverse command - corner case} {
+test string-24.11.$noComp {string reverse command - corner case} {
set x \uBEEF
set y \uD0AD
- string reverse $x$y
+ run {string reverse $x$y}
} \uD0AD\uBEEF
-test string-24.12 {string reverse command - corner case} {
+test string-24.12.$noComp {string reverse command - corner case} {
set x \uBEEF
set y \uD0AD
- string is ascii [string reverse $x$y]
+ run {string is ascii [run {string reverse $x$y}]}
} 0
-test string-24.13 {string reverse command - pure Unicode string} {
- string reverse [string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5]
+test string-24.13.$noComp {string reverse command - pure Unicode string} {
+ run {string reverse [run {string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5}]}
} \uD0AD\uBEEF\uD0AD\uBEEF\uD0AD
-test string-24.14 {string reverse command - pure bytearray} {
- binary scan [string reverse [binary format H* 010203]] H* x
+test string-24.14.$noComp {string reverse command - pure bytearray} {
+ binary scan [run {string reverse [binary format H* 010203]}] H* x
set x
} 030201
-test string-24.15 {string reverse command - pure bytearray} {
- binary scan [tcl::string::reverse [binary format H* 010203]] H* x
+test string-24.15.$noComp {string reverse command - pure bytearray} {
+ binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x
set x
} 030201
-test string-25.1 {string is list} {
- string is list {a b c}
+test string-25.1.$noComp {string is list} {
+ run {string is list {a b c}}
} 1
-test string-25.2 {string is list} {
- string is list "a \{b c"
+test string-25.2.$noComp {string is list} {
+ run {string is list "a \{b c"}
} 0
-test string-25.3 {string is list} {
- string is list {a {b c}d e}
+test string-25.3.$noComp {string is list} {
+ run {string is list {a {b c}d e}}
} 0
-test string-25.4 {string is list} {
- string is list {}
+test string-25.4.$noComp {string is list} {
+ run {string is list {}}
} 1
-test string-25.5 {string is list} {
- string is list -strict {a b c}
+test string-25.5.$noComp {string is list} {
+ run {string is list -strict {a b c}}
} 1
-test string-25.6 {string is list} {
- string is list -strict "a \{b c"
+test string-25.6.$noComp {string is list} {
+ run {string is list -strict "a \{b c"}
} 0
-test string-25.7 {string is list} {
- string is list -strict {a {b c}d e}
+test string-25.7.$noComp {string is list} {
+ run {string is list -strict {a {b c}d e}}
} 0
-test string-25.8 {string is list} {
- string is list -strict {}
+test string-25.8.$noComp {string is list} {
+ run {string is list -strict {}}
} 1
-test string-25.9 {string is list} {
+test string-25.9.$noComp {string is list} {
set x {}
- list [string is list -failindex x {a b c}] $x
+ list [run {string is list -failindex x {a b c}}] $x
} {1 {}}
-test string-25.10 {string is list} {
+test string-25.10.$noComp {string is list} {
set x {}
- list [string is list -failindex x "a \{b c"] $x
+ list [run {string is list -failindex x "a \{b c"}] $x
} {0 2}
-test string-25.11 {string is list} {
+test string-25.11.$noComp {string is list} {
set x {}
- list [string is list -failindex x {a b {b c}d e}] $x
+ list [run {string is list -failindex x {a b {b c}d e}}] $x
} {0 4}
-test string-25.12 {string is list} {
+test string-25.12.$noComp {string is list} {
set x {}
- list [string is list -failindex x {}] $x
+ list [run {string is list -failindex x {}}] $x
} {1 {}}
-test string-25.13 {string is list} {
+test string-25.13.$noComp {string is list} {
set x {}
- list [string is list -failindex x { {b c}d e}] $x
+ list [run {string is list -failindex x { {b c}d e}}] $x
} {0 2}
-test string-25.14 {string is list} {
+test string-25.14.$noComp {string is list} {
set x {}
- list [string is list -failindex x "\uABCD {b c}d e"] $x
+ list [run {string is list -failindex x "\uABCD {b c}d e"}] $x
} {0 2}
-test string-26.1 {tcl::prefix, too few args} -body {
+test string-26.1.$noComp {tcl::prefix, too few args} -body {
tcl::prefix match a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"}
-test string-26.2 {tcl::prefix, bad args} -body {
+test string-26.2.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match a b c
} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
-test string-26.2.1 {tcl::prefix, empty table} -body {
+test string-26.2.1.$noComp {tcl::prefix, empty table} -body {
tcl::prefix match {} foo
} -returnCodes 1 -result {bad option "foo": no valid options}
-test string-26.3 {tcl::prefix, bad args} -body {
+test string-26.3.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -error "{}x" -exact str1 str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
-test string-26.3.1 {tcl::prefix, bad args} -body {
+test string-26.3.1.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -error "x" -exact str1 str2
} -returnCodes 1 -result {error options must have an even number of elements}
-test string-26.3.2 {tcl::prefix, bad args} -body {
+test string-26.3.2.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -error str1 str2
} -returnCodes 1 -result {missing value for -error}
-test string-26.4 {tcl::prefix, bad args} -body {
+test string-26.4.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
} -returnCodes 1 -result {missing value for -message}
-test string-26.5 {tcl::prefix} {
+test string-26.5.$noComp {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
-test string-26.6 {tcl::prefix} {
+test string-26.6.$noComp {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} be
} bepa
-test string-26.7 {tcl::prefix} -body {
+test string-26.7.$noComp {tcl::prefix} -body {
tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
-test string-26.8 {tcl::prefix} -body {
+test string-26.8.$noComp {tcl::prefix} -body {
tcl::prefix match -message wombat {apa bepa bear depa} be
} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa}
-test string-26.9 {tcl::prefix} -body {
+test string-26.9.$noComp {tcl::prefix} -body {
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
-test string-26.10 {tcl::prefix} -body {
+test string-26.10.$noComp {tcl::prefix} -body {
tcl::prefix match -error {-level 1} {apa bepa bear depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa}
-test string-26.10.1 {tcl::prefix} -setup {
+test string-26.10.1.$noComp {tcl::prefix} -setup {
proc _testprefix {args} {
array set opts {-a x -b y -c y}
foreach {opt val} $args {
@@ -1914,7 +2178,7 @@ proc MemStress {args} {
return $res
}
-test string-26.11 {tcl::prefix: testing for leaks} -body {
+test string-26.11.$noComp {tcl::prefix: testing for leaks} -body {
# This test is made to stress object reference management
MemStress {
set table {hejj miff gurk}
@@ -1935,7 +2199,7 @@ test string-26.11 {tcl::prefix: testing for leaks} -body {
}
} -constraints memory -result {0 0 0}
-test string-26.12 {tcl::prefix: testing for leaks} -body {
+test string-26.12.$noComp {tcl::prefix: testing for leaks} -body {
# This is a memory leak test in a form that might actually happen
# in real code. The shared literal "miff" causes a connection
# between the item and the table.
@@ -1953,7 +2217,7 @@ test string-26.12 {tcl::prefix: testing for leaks} -body {
}
} -constraints memory -result 0
-test string-26.13 {tcl::prefix: testing for leaks} -body {
+test string-26.13.$noComp {tcl::prefix: testing for leaks} -body {
# This test is made to stress object reference management
MemStress {
set table [list hejj miff]
@@ -1966,110 +2230,317 @@ test string-26.13 {tcl::prefix: testing for leaks} -body {
}
} -constraints memory -result {0}
-test string-27.1 {tcl::prefix all, too few args} -body {
+test string-27.1.$noComp {tcl::prefix all, too few args} -body {
tcl::prefix all a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
-test string-27.2 {tcl::prefix all, bad args} -body {
+test string-27.2.$noComp {tcl::prefix all, bad args} -body {
tcl::prefix all a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
-test string-27.3 {tcl::prefix all, bad args} -body {
+test string-27.3.$noComp {tcl::prefix all, bad args} -body {
tcl::prefix all "{}x" str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
-test string-27.4 {tcl::prefix all} {
+test string-27.4.$noComp {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} c
} cepa
-test string-27.5 {tcl::prefix all} {
+test string-27.5.$noComp {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} cepa
} cepa
-test string-27.6 {tcl::prefix all} {
+test string-27.6.$noComp {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} cepax
} {}
-test string-27.7 {tcl::prefix all} {
+test string-27.7.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} a
} {apa aska appa}
-test string-27.8 {tcl::prefix all} {
+test string-27.8.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} ap
} {apa appa}
-test string-27.9 {tcl::prefix all} {
+test string-27.9.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} p
} {}
-test string-27.10 {tcl::prefix all} {
+test string-27.10.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} {}
} {apa aska appa}
-test string-28.1 {tcl::prefix longest, too few args} -body {
+test string-28.1.$noComp {tcl::prefix longest, too few args} -body {
tcl::prefix longest a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
-test string-28.2 {tcl::prefix longest, bad args} -body {
+test string-28.2.$noComp {tcl::prefix longest, bad args} -body {
tcl::prefix longest a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
-test string-28.3 {tcl::prefix longest, bad args} -body {
+test string-28.3.$noComp {tcl::prefix longest, bad args} -body {
tcl::prefix longest "{}x" str2
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}
-test string-28.4 {tcl::prefix longest} {
+test string-28.4.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} c
} cepa
-test string-28.5 {tcl::prefix longest} {
+test string-28.5.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} cepa
} cepa
-test string-28.6 {tcl::prefix longest} {
+test string-28.6.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} cepax
} {}
-test string-28.7 {tcl::prefix longest} {
+test string-28.7.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa aska appa} a
} a
-test string-28.8 {tcl::prefix longest} {
+test string-28.8.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa aska appa} ap
} ap
-test string-28.9 {tcl::prefix longest} {
+test string-28.9.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bska appa} a
} ap
-test string-28.10 {tcl::prefix longest} {
+test string-28.10.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa bska appa} {}
} {}
-test string-28.11 {tcl::prefix longest} {
+test string-28.11.$noComp {tcl::prefix longest} {
tcl::prefix longest {{} bska appa} {}
} {}
-test string-28.12 {tcl::prefix longest} {
+test string-28.12.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa {} appa} {}
} {}
-test string-28.13 {tcl::prefix longest} {
+test string-28.13.$noComp {tcl::prefix longest} {
# Test UTF8 handling
tcl::prefix longest {ax\x90 bep ax\x91} a
} ax
-test string-29.1 {string cat, no arg} {
- string cat
+test string-29.1.$noComp {string cat, no arg} {
+ run {string cat}
} ""
-test string-29.2 {string cat, single arg} {
+test string-29.2.$noComp {string cat, single arg} {
set x FOO
- string compare $x [string cat $x]
+ run {string compare $x [run {string cat $x}]}
} 0
-test string-29.3 {string cat, two args} {
+test string-29.3.$noComp {string cat, two args} {
set x FOO
- string compare $x$x [string cat $x $x]
+ run {string compare $x$x [run {string cat $x $x}]}
} 0
-test string-29.4 {string cat, many args} {
+test string-29.4.$noComp {string cat, many args} {
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"]]
+ set xx [run {string repeat $x $n}]
+ set vv [run {string repeat {$x} $n}]
+ set vvs [run {string repeat {$x } $n}]
+ set r1 [run {string compare $xx [subst $vv]}]
+ 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 {[Bug ba921a8d98]: string cat} {
- string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]
+test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
+ run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
-test string-30.1.2 {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
- set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"
+test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
+ 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-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}
+
# 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 2aeb08e..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 {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- 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 will fail if the underlying comparaison
- # 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 utf8 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} {
- string compare -length 2 abc abde
- } 0 {}
- {with length, unequal strings} {
- 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 49f268e..3779bca 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -23,6 +23,8 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
+testConstraint tip389 [expr {[string length \U010000] == 2}]
+testConstraint nodep [info exists tcl_precision]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
@@ -439,9 +441,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,23 +466,22 @@ 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 nodep} {
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 nodep} {
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 nodep} {
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 nodep} {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
-
if {[testConstraint testobj]} {
testobj freeallvars
@@ -489,3 +490,7 @@ if {[testConstraint testobj]} {
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/subst.test b/tests/subst.test
index 189dfe8..1f3c22a 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -166,7 +166,7 @@ test subst-8.6 {return in a subst} -returnCodes error -body {
subst "foo \[return {x}; bogus code bar"
} -result {missing close-bracket}
test subst-8.7 {return in a subst, parse error} -body {
- subst {foo [return {x} ; set a {}"" ; stuff] bar}
+ subst {foo [return {x} ; set a {}"" ; stuff] bar}
} -returnCodes error -result {extra characters after close-brace}
test subst-8.8 {return in a subst, parse error} -body {
subst {foo [return {x} ; set bar baz ; set a {}"" ; stuff] bar}
diff --git a/tests/tailcall.test b/tests/tailcall.test
index 3751c35..9174167 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -28,9 +28,9 @@ if {[testConstraint testnrelevels]} {
namespace eval testnre {
#
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
- # cmdFrame level, callFrame level, tosPtr and callback depth
+ # cmdFrame level, callFrame level, tosPtr and callback depth
#
- variable last [testnrelevels]
+ variable last [testnrelevels]
proc depthDiff {} {
variable last
set depth [testnrelevels]
@@ -148,7 +148,7 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup
} -result {0 0 0 0 0 0}
test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup {
- #
+ #
# This test is related to [bug d87cb182053fd79b3]: the fix to that bug was
# to remove a call to TclSkipTailcall, which caused a violation of the
# constant-space property of tailcall in that particular
@@ -245,7 +245,7 @@ test tailcall-1 {tailcall} -body {
}
variable x *::
proc xset args {error ::xset}
- list [::b::moo] | $x $a::x $b::x | $::b::y
+ list [::b::moo] | $x $a::x $b::x | $::b::y
} -cleanup {
unset x
rename xset {}
@@ -619,7 +619,7 @@ test tailcall-12.3a3 {[Bug 2695587]} -body {
set x
} -cleanup {
unset x
-} -result {0 1}
+} -result {0 1}
test tailcall-12.3b0 {[Bug 2695587]} -body {
apply {{} {
@@ -654,7 +654,7 @@ test tailcall-12.3b3 {[Bug 2695587]} -body {
set x
} -cleanup {
unset x
-} -result {0 1}
+} -result {0 1}
# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed)
# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that
diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl
index a1fdb3d..b0aa054 100644
--- a/tests/tcltests.tcl
+++ b/tests/tcltests.tcl
@@ -2,7 +2,6 @@
package require tcltest 2.2
namespace import ::tcltest::*
-
testConstraint exec [llength [info commands exec]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
@@ -10,6 +9,7 @@ testConstraint thread [
expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
+
namespace eval ::tcltests {
@@ -42,5 +42,5 @@ namespace eval ::tcltests {
init
package provide tcltests 0.1
-
}
+
diff --git a/tests/thread.test b/tests/thread.test
index eaaaa41..2524911 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -11,14 +11,17 @@
# 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
+ 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.
-package require tcltests
-
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+package require tcltests
# Some tests require the testthread command
diff --git a/tests/trace.test b/tests/trace.test
index d830f3c..1099f48 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -164,30 +164,30 @@ test trace-1.10 {trace variable reads} {
} {}
test trace-1.11 {read traces that modify the array structure} {
unset -nocomplain x
- set x(bar) 0
- trace variable x r {set x(foo) 1 ;#}
- trace variable x r {unset -nocomplain x(bar) ;#}
+ set x(bar) 0
+ trace variable x r {set x(foo) 1 ;#}
+ trace variable x r {unset -nocomplain x(bar) ;#}
array get x
} {}
test trace-1.12 {read traces that modify the array structure} {
unset -nocomplain x
- set x(bar) 0
- trace variable x r {unset -nocomplain x(bar) ;#}
- trace variable x r {set x(foo) 1 ;#}
+ set x(bar) 0
+ trace variable x r {unset -nocomplain x(bar) ;#}
+ trace variable x r {set x(foo) 1 ;#}
array get x
} {}
test trace-1.13 {read traces that modify the array structure} {
unset -nocomplain x
- set x(bar) 0
- trace variable x r {set x(foo) 1 ;#}
- trace variable x r {unset -nocomplain x;#}
+ set x(bar) 0
+ trace variable x r {set x(foo) 1 ;#}
+ trace variable x r {unset -nocomplain x;#}
list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}
test trace-1.14 {read traces that modify the array structure} {
unset -nocomplain x
- set x(bar) 0
- trace variable x r {unset -nocomplain x;#}
- trace variable x r {set x(foo) 1 ;#}
+ set x(bar) 0
+ trace variable x r {unset -nocomplain x;#}
+ trace variable x r {set x(foo) 1 ;#}
list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}
@@ -419,7 +419,7 @@ test trace-5.8 {array traces fire for undefined variables} {
trace add variable x array {set x(foo) 1 ;#}
set res "names: [array names x]"
} {names: foo}
-
+
# Trace multiple trace types at once.
test trace-6.1 {multiple ops traced at once} {
@@ -767,7 +767,7 @@ test trace-13.1 {delete one trace from another} {
trace add variable x read {traceTag 2}
trace add variable x read {traceTag 3}
trace add variable x read {traceTag 4}
- trace add variable x read delTraces
+ trace add variable x read delTraces
trace add variable x read {traceTag 5}
set x
set info
@@ -872,7 +872,7 @@ test trace-14.5 {trace command, invalid option} {
} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
# Again, [trace ... command] and [trace ... variable] share syntax and
-# error message styles for their opList options; these loops test those
+# error message styles for their opList options; these loops test those
# error messages.
set i 0
@@ -2104,7 +2104,7 @@ foo foo 0 1 leave}
test trace-28.2 {exec traces with 'error'} {
set info {}
set res {}
-
+
proc foo {} {
if {[catch {bar}]} {
return "error"
@@ -2126,7 +2126,7 @@ test trace-28.2 {exec traces with 'error'} {
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
-
+
list $res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
@@ -2152,7 +2152,7 @@ foo foo 0 error leave}}
test trace-28.3 {exec traces with 'return -code error'} {
set info {}
set res {}
-
+
proc foo {} {
if {[catch {bar}]} {
return "error"
@@ -2174,7 +2174,7 @@ test trace-28.3 {exec traces with 'return -code error'} {
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
-
+
list $res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
@@ -2204,7 +2204,7 @@ test trace-28.4 {exec traces in slave with 'return -code error'} {
set res [interp eval slave {
set info {}
set res {}
-
+
proc foo {} {
if {[catch {bar}]} {
return "error"
@@ -2212,21 +2212,21 @@ test trace-28.4 {exec traces in slave with 'return -code error'} {
return "ok"
}
}
-
+
proc bar {} { return -code error "msg" }
-
+
lappend res [foo]
-
+
trace add execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
-
+
# With the trace active
-
+
lappend res [foo]
-
+
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
-
+
list $res
}]
interp delete slave
@@ -2610,7 +2610,7 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup {
proc foo {} {
incr ::traceCalls
# choose a BC'ed command that is 'unlikely' to interfere with tcltest's
- # internals
+ # internals
lset ::bar 1 2
}
} -body {
@@ -2631,7 +2631,7 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup {
rename dotrace {}
rename foo {}
} -result {3 | 0 1 1}
-
+
test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup {
set ::traceLog 0
set ::traceCalls 0
@@ -2668,7 +2668,7 @@ test trace-40.1 {execution trace errors become command errors} {
catch foo m
return -level 0 $m[unset m]
} bar
-
+
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index 183c145..08eb664 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -221,12 +221,12 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup {
cleanup
} -constraints {unix notRoot} -body {
close [open tf1 a]
- file attributes tf1 -permissions 0472
+ file attributes tf1 -permissions 0o472
file copy tf1 tf2
file attributes tf2 -permissions
} -cleanup {
cleanup
-} -result 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
+} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} {
} {}
@@ -375,11 +375,11 @@ proc permcheck {testnum permList expected} {
set result
} $expected
}
-permcheck unixFCmd-17.5 rwxrwxrwx 00777
-permcheck unixFCmd-17.6 r--r---w- 00442
-permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547}
-permcheck unixFCmd-17.11 --x--x--x 00111
-permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777}
+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} {00000 0o740 0o540 0o547}
+permcheck unixFCmd-17.11 --x--x--x 0o111
+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 {
diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test
index 120f362..d7b86fd 100644
--- a/tests/unixForkEvent.test
+++ b/tests/unixForkEvent.test
@@ -37,7 +37,7 @@ test unixforkevent-1.1 {fork and test writeable event} \
viewFile result.txt $myFolder
} \
-result {writable} \
- -cleanup {
+ -cleanup {
catch { removeFolder $myFolder }
}
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 681a931..ab00b4e 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -15,6 +15,9 @@ namespace import ::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 +90,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)]} {
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 2f03529..0bd8c69 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -18,27 +18,22 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
# 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}
vwait x
close $f
list [catch {vwait x} msg] $msg
-} -result {1 {can't wait for variable "x": would wait forever}} -cleanup {
+} -result {1 {can't wait for variable "x": would wait forever}} -cleanup {
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]
@@ -90,7 +85,7 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
set x
} \
-result {ok} \
- -cleanup {
+ -cleanup {
catch { close $f1 }
catch { close $f2 }
catch { removeFile foo }
diff --git a/tests/uplevel.test b/tests/uplevel.test
index 9fe1645..2cbea1a 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -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"}
@@ -247,7 +247,7 @@ test uplevel-7.1 {var access, no LVT in either level} -setup {
unset -nocomplain y z
} -body {
namespace eval foo {
- set x 2
+ set x 2
set y 2
uplevel 1 {
set x 3
@@ -266,7 +266,7 @@ test uplevel-7.2 {var access, no LVT in upper level} -setup {
unset -nocomplain y z
} -body {
proc foo {} {
- set x 2
+ set x 2
set y 2
uplevel 1 {
set x 3
@@ -290,7 +290,7 @@ test uplevel-7.3 {var access, LVT in upper level} -setup {
}
} -body {
proc foo {} {
- set x 2
+ set x 2
set y 2
uplevel 1 {
set x 3
diff --git a/tests/upvar.test b/tests/upvar.test
index aea9333..a483569 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -492,7 +492,7 @@ test upvar-NS-1.4 {nsupvar links to correct variable} -body {
} -returnCodes error -cleanup {
namespace delete test_ns_1
} -result {namespace "test_ns_0" not found in "::test_ns_1"}
-
+
test upvar-NS-1.5 {nsupvar links to correct variable} -body {
namespace eval test_ns_1 {
namespace eval test_ns_0 {}
diff --git a/tests/utf.test b/tests/utf.test
index 14b2198..fdbc4e1 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -21,6 +21,7 @@ testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}]
testConstraint ucs4 [expr {[testConstraint fullutf]
&& [string length [format %c 0x10000]] == 1}]
+testConstraint ucs2_utf16 [expr {![testConstraint ucs4]}]
testConstraint Uesc [expr {"\U0041" eq "A"}]
testConstraint pre388 [expr {"\x741" eq "A"}]
@@ -103,7 +104,7 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring \xE4\xB9\x8E]
} 1
-test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} {
+test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2_utf16} {
string length [testbytestring \xF0\x90\x80\x80]
} 2
test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} {
@@ -217,7 +218,7 @@ test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} {
} 1
test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
-} 1
+} 2
test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xD0]
} 1
@@ -272,19 +273,19 @@ test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} {
test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF8]
} 1
-test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2]
} 1
-test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2]
} -1
test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2]G
} 1
-test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0]
} 1
-test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0]
} -1
test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} {
@@ -395,10 +396,10 @@ test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} {
test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0]G
} 1
-test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 1
-test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 4
test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} {
@@ -413,40 +414,40 @@ test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} {
test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF8]
} 1
-test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 1
-test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 4
-test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 1
-test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 4
-test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 1
-test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 4
-test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 1
-test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 4
-test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 1
-test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 4
-test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
+test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 1
-test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 4
test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext {
@@ -470,22 +471,22 @@ test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xF0\x80\x80\x80]
} 1
-test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2} {
+test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 1
-test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring fullutf} {
+test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 4
test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
-} 1
+} 2
test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x00]
-} 1
-test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2} {
+} 2
+test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 1
-test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring fullutf} {
+test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 4
test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} {
@@ -493,121 +494,16 @@ test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytest
} 1
test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0]
-} 1
+} 3
test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80]
-} 1
+} 3
test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0\xA0]
-} 1
+} 3
test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80\x80]
-} 1
-test utf-6.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
-test utf-6.110 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 1
-} 0
-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
-test utf-6.114 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 1
-} 0
-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 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0\xA0]G 3
-} 1
-test utf-6.124 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0] 3
-} 1
-test utf-6.125 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0]G 4
-} 1
-test utf-6.126 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0\xA0] 4
-} 1
test utf-7.1 {Tcl_UtfPrev} testutfprev {
testutfprev {}
@@ -765,30 +661,30 @@ test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4
} 3
-test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring} {
+test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0]
-} 3
-test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 1
+test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4
-} 3
-test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 1
+test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4
-} 3
-test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 1
+test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0]
-} 4
-test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 2
+test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0]
-} 4
-test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 2
+test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A\u8820[testbytestring \xA0]
-} 4
-test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 2
+test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0]
-} 4
-test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring} {
+} 2
+test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0]
-} 4
+} 2
test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81]
} 2
@@ -810,9 +706,9 @@ test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 2
} 1
-test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
+test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x80\x80\x80]
-} 4
+} 2
test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 4
} 3
@@ -840,9 +736,9 @@ test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 2
} 1
-test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
+test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x90\x80\x80]
-} 4
+} 2
test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 3
@@ -867,9 +763,9 @@ test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestrin
test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0\xA0]
} 2
-test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
+test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring utf16} {
testutfprev [testbytestring \xA0\xA0\xA0\xA0]
-} 3
+} 1
test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0]
} 0
@@ -879,9 +775,9 @@ test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} tes
test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0\x00] 2
} 0
-test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
+test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF]
-} 4
+} 2
test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 3
@@ -897,9 +793,9 @@ test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbyte
test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2
} 1
-test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
+test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x90\x80\x80]
-} 4
+} 2
test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 4
} 3
@@ -1387,8 +1283,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
@@ -1416,7 +1312,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/util.test b/tests/util.test
index f5a59ee..1d8162c 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -20,6 +20,10 @@ 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]
@@ -278,7 +282,7 @@ test util-5.17 {Tcl_StringMatch: UTF-8} {
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]
+ Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
@@ -388,7 +392,7 @@ test util-5.52 {Tcl_StringMatch} {
} 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 {
@@ -396,7 +400,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 {
@@ -404,7 +408,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 {
@@ -412,7 +416,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 {
@@ -427,7 +431,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
@@ -437,7 +441,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
@@ -449,7 +453,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
@@ -462,7 +466,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
@@ -571,188 +575,249 @@ test util-8.11 {TclNeedSpace - watch out for escaped space} {
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-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
@@ -2162,7 +2227,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} \
@@ -2176,7 +2240,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} {
@@ -2206,1828 +2270,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
@@ -4060,7 +4124,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 32388a2..a5b91f8 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -41,6 +41,7 @@ if {[testConstraint memory]} {
}
}
+
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
@@ -53,7 +54,7 @@ catch {unset arr}
test var-1.1 {TclLookupVar, Array handling} -setup {
catch {unset a}
} -body {
- set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd
+ set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd
set i 10
set arr(foo) 37
list [$x i] $i [$x arr(foo)] $arr(foo)
@@ -256,7 +257,7 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup {
set a 123321
proc p {} {
# create global xx linked to global a
- testupvar 1 a {} xx global
+ testupvar 1 a {} xx global
}
list [p] $xx [set xx 789] $a
} -result {{} 123321 789 789}
@@ -268,7 +269,7 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup {
catch {unset ::test_ns_var::vv}
proc p {} {
# create namespace var vv linked to global a
- testupvar 1 a {} vv namespace
+ testupvar 1 a {} vv namespace
}
p
}
@@ -570,11 +571,11 @@ test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body {
namespace eval test_ns_var { variable arrayvar(1) }
} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array"
test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body {
- namespace eval test_ns_var {
+ namespace eval test_ns_var {
variable arrayvar
set arrayvar(1) x
variable arrayvar(1) y
- }
+ }
} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array"
test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} {
variable
@@ -828,7 +829,7 @@ test var-15.1 {segfault in [unset], [Bug 735335]} {
set var $name
}
#
- # Note that the variable name has to be
+ # Note that the variable name has to be
# unused previously for the segfault to
# be triggered.
#
@@ -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 intrep: Bug 80304238ac} -setup {
- proc getbytes {} {
- lindex [split [memory info] \n] 3 3
- }
proc doit {} {
interp create slave
slave eval {
@@ -1066,15 +1060,431 @@ test var-22.1 {leak in localVarName intrep: 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/winFCmd.test b/tests/winFCmd.test
index 2ce4916..2bce77c 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -21,8 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
# Initialise the test constraints
testConstraint winVista 0
-testConstraint win2000orXP 0
-testConstraint winOlderThan2000 0
+testConstraint winXP 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
testConstraint testchmod [llength [info commands testchmod]]
@@ -57,15 +56,11 @@ 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
- }
+if {[testConstraint win]} {
+ if {$::tcl_platform(osVersion) >= 5.0} {
+ testConstraint winVista 1
} else {
- testConstraint winOlderThan2000 1
+ testConstraint winXP 1
}
}
@@ -210,17 +205,12 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup {
} -returnCodes error -result EACCES
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
cleanup
-} -constraints {win win2000orXP testfile} -body {
+} -constraints {win winXP 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
@@ -243,19 +233,12 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup {
} -returnCodes error -result ENOENT
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup {
cleanup
-} -constraints {win win2000orXP testfile} -body {
+} -constraints {win winXP 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
@@ -463,14 +446,9 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup {
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
cleanup
-} -constraints {win win2000orXP testfile} -body {
+} -constraints {win winXP 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 {
@@ -628,7 +606,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 {
@@ -726,7 +704,7 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
} -result {td1 EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile} -body {
testfile rmdir /
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
@@ -824,7 +802,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} {
@@ -862,7 +840,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 {
@@ -1077,7 +1055,7 @@ test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body {
} -constraints {win} -result {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
catch {file delete -force -- c:/TclTmpC.1}
-} -constraints {win win2000orXP} -body {
+} -constraints {win winXP} -body {
createfile c:/TclTmpC.1 {}
string tolower [file attributes c:/TclTmpC.1 -longname]
} -cleanup {
@@ -1364,13 +1342,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 {
@@ -1381,7 +1359,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 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 {
@@ -1392,7 +1370,7 @@ test winFCmd-19.4 {Windows extended path names} -constraints 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 {
@@ -1403,7 +1381,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 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 {
@@ -1414,7 +1392,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.7 {Windows extended path names} -constraints 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 {
@@ -1425,7 +1403,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {} [list tcl[pid].tmp]]
-test winFCmd-19.8 {Windows extended path names} -constraints 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 {
@@ -1437,7 +1415,7 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup {
catch {file delete $tmpfile}
} -result [list 0 {} [list "tcl[pid].tmp "]]
-test winFCmd-19.9 {Windows devices path names} -constraints 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 eb6addd..b288063 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -21,23 +21,19 @@ catch [list package require -exact Tcltest [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
-}
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
} -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
} -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
} -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/winPipe.test b/tests/winPipe.test
index 06bd67e..7e01c5f 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -39,7 +39,7 @@ testConstraint slowTest 0
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
-append big $big
+append big $big
append big $big
append big $big
append big $big
@@ -79,11 +79,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"
@@ -176,7 +176,7 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
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] } {
diff --git a/tests/zipfs.test b/tests/zipfs.test
new file mode 100644
index 0000000..2ecbdfa
--- /dev/null
+++ b/tests/zipfs.test
@@ -0,0 +1,284 @@
+# 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 (c) 1996-1998 by 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.1
+ namespace import -force ::tcltest::*
+}
+
+testConstraint zipfs [expr {
+ [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]
+}]
+testConstraint zipfslib 1
+
+# Removed in tip430 - zipfs is no longer a static package
+#test zipfs-0.0 {zipfs basics} -constraints zipfs -body {
+# load {} zipfs
+#} -result {}
+
+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 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 [::tcl::pkgconfig get zipfile,runtime]]
+ 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}
+
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/zlib.test b/tests/zlib.test
index d3a6dff..463cc7c 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -1032,7 +1032,7 @@ test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zl
close $chanin
close $chanout
} -body {
- file size $pathout
+ file size $pathout
} -cleanup {
removeFile $pathout
unset chanin pathin chanout pathout
@@ -1069,7 +1069,7 @@ test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints
fcopy $chanin $chanout
chan pop $chanin
close $chanout
- #
+ #
list [file size $pathout1] [file size $pathout2]
} -cleanup {
close $chanin
diff --git a/tools/configure b/tools/configure
index 3d30039..5903cc8 100755
--- a/tools/configure
+++ b/tools/configure
@@ -1,81 +1,458 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.59.
+# Generated by GNU Autoconf 2.69.
+#
+#
+# Copyright (C) 1992-1996, 1998-2012 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
+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
+ # 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
+ 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
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
else
- as_unset=false
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
+fi
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; 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
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# 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
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
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
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+# 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'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+as_fn_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="if test -n \"\${ZSH_VERSION+set}\" && (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
+ 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
+ exitcode=1; echo positional parameters were not saved.
+fi
+test x\$exitcode = x0 || 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"
+ if (eval "$as_required") 2>/dev/null; then :
+ as_have_required=yes
+else
+ as_have_required=no
+fi
+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then :
+
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+as_found=false
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
do
- if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
- eval $as_var=C; export $as_var
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ CONFIG_SHELL=$as_shell as_have_required=yes
+ if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ break 2
+fi
+fi
+ done;;
+ esac
+ as_found=false
+done
+$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then :
+ CONFIG_SHELL=$SHELL as_have_required=yes
+fi; }
+IFS=$as_save_IFS
+
+
+ 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'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
+fi
+
+ if test x$as_have_required = xno; then :
+ $as_echo "$0: This script requires a shell more modern than all"
+ $as_echo "$0: the shells that I found on your system."
+ if test x${ZSH_VERSION+set} = xset ; then
+ $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should"
+ $as_echo "$0: be upgraded to zsh 4.3.4 or later."
else
- $as_unset $as_var
+ $as_echo "$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
-done
+ 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
-# 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_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=`$as_echo "$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 ||
+$as_echo 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_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_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+
+# 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
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ $as_echo "$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 ||
+$as_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'
@@ -83,146 +460,91 @@ 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" ||
+ { $as_echo "$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= ;;
+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
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
else
- as_expr=false
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
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
+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,38 +553,25 @@ 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=
@@ -270,14 +579,70 @@ PACKAGE_TARNAME=
PACKAGE_VERSION=
PACKAGE_STRING=
PACKAGE_BUGREPORT=
+PACKAGE_URL=
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_vars='LTLIBOBJS
+LIBOBJS
+TCL_BIN_DIR
+TCL_SRC_DIR
+TCL_PATCH_LEVEL
+TCL_VERSION
+CC
+TCL_WIN_VERSION
+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
+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'
ac_subst_files=''
+ac_user_opts='
+enable_option_checking
+with_tcl
+'
+ ac_precious_vars='build_alias
+host_alias
+target_alias'
+
# 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
@@ -300,34 +665,49 @@ 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'
includedir='${prefix}/include'
oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
+docdir='${datarootdir}/doc/${PACKAGE}'
+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[^=]*=\(.*\)'`
+ case $ac_option in
+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *=) ac_optarg= ;;
+ *) ac_optarg=yes ;;
+ esac
# Accept the important Cygnus configure options, so we can diagnose typos.
- case $ac_option in
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
@@ -349,33 +729,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=`$as_echo "$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=`$as_echo "$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- \
@@ -402,6 +808,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 ;;
@@ -426,13 +838,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)
@@ -497,6 +912,16 @@ 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 ;;
@@ -547,26 +972,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=`$as_echo "$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=`$as_echo "$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.
@@ -586,27 +1021,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
+ $as_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}
+ $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
@@ -614,31 +1048,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" ;;
+ *) $as_echo "$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
do
- eval ac_val=$`echo $ac_var`
+ eval ac_val=\$$ac_var
+ # Remove trailing slashes.
+ case $ac_val in
+ */ )
+ 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
- [\\/$]* | ?:[\\/]* ) ;;
- *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
- { (exit 1); exit 1; }; };;
+ [\\/$]* | ?:[\\/]* ) 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'
@@ -652,8 +1091,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
@@ -665,54 +1102,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 ||
+$as_echo 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
+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
-(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
+# 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.
@@ -735,20 +1190,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
@@ -758,18 +1210,25 @@ 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]
+ --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/PACKAGE]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
@@ -785,119 +1244,93 @@ Optional Packages:
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--with-tcl=DIR use Tcl $DEF_VER binaries from DIR
+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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$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 guested 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
else
- echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi
- cd $ac_popdir
+ $as_echo "$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
+configure
+generated by GNU Autoconf 2.69
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2012 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. ##
+## ------------------------ ##
+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 $as_me, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
_ACEOF
+exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
@@ -916,7 +1349,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`
@@ -928,8 +1361,9 @@ for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
- echo "PATH: $as_dir"
-done
+ $as_echo "PATH: $as_dir"
+ done
+IFS=$as_save_IFS
} >&5
@@ -951,7 +1385,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
@@ -962,13 +1395,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=`$as_echo "$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
@@ -984,104 +1417,115 @@ 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=$?
# Save into config.log some information that might help in debugging.
{
echo
- cat <<\_ASBOX
-## ---------------- ##
+ $as_echo "## ---------------- ##
## 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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$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
-## ----------------- ##
+ $as_echo "## ----------------- ##
## 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=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
- cat <<\_ASBOX
-## ------------- ##
-## Output files. ##
-## ------------- ##
-_ASBOX
+ $as_echo "## ------------------- ##
+## 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=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
- cat <<\_ASBOX
-## ----------- ##
+ $as_echo "## ----------- ##
## 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"
+ $as_echo "$as_me: caught signal $ac_signal"
+ $as_echo "$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
+rm -f -r conftest* confdefs.h
+
+$as_echo "/* confdefs.h */" > confdefs.h
# Predefined preprocessor variables.
@@ -1089,112 +1533,137 @@ 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
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_URL "$PACKAGE_URL"
+_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
+# Prefer an explicitly selected file to automatically selected ones.
+ac_site_file1=NONE
+ac_site_file2=NONE
+if test -n "$CONFIG_SITE"; then
+ # We do not want a PATH search for config.site.
+ case $CONFIG_SITE in #((
+ -*) ac_site_file1=./$CONFIG_SITE;;
+ */*) ac_site_file1=$CONFIG_SITE;;
+ *) ac_site_file1=./$CONFIG_SITE;;
+ esac
+elif test "x$prefix" != xNONE; then
+ ac_site_file1=$prefix/share/config.site
+ ac_site_file2=$prefix/etc/config.site
+else
+ ac_site_file1=$ac_default_prefix/share/config.site
+ ac_site_file2=$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_file1" "$ac_site_file2"
+do
+ test "x$ac_site_file" = xNONE && continue
+ if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
+$as_echo "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file"
+ . "$ac_site_file" \
+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
+$as_echo "$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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
+$as_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
+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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+$as_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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
+$as_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=:
+ # 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
+$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ ac_cache_corrupted=:
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
+$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
+ eval $ac_var=\$ac_old_val
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
+$as_echo "$as_me: former value: \`$ac_old_val'" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
+$as_echo "$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=`$as_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'" ;;
+ *) 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; }; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
+$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5
fi
+## -------------------- ##
+## Main body of script. ##
+## -------------------- ##
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
@@ -1205,23 +1674,6 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
# Recover information that Tcl computed with its configure script.
#--------------------------------------------------------------------
@@ -1229,25 +1681,21 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
-DEF_VER=8.6
+DEF_VER=8.7
-# Check whether --with-tcl or --without-tcl was given.
-if test "${with_tcl+set}" = set; then
- withval="$with_tcl"
- TCL_BIN_DIR=$withval
+# Check whether --with-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;
+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; }; }
+ as_fn_error $? "Tcl directory $TCL_BIN_DIR doesn't exist" "$LINENO" 5
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; }; }
+ as_fn_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?" "$LINENO" 5
fi
. $TCL_BIN_DIR/tclConfig.sh
@@ -1261,7 +1709,8 @@ CC=$TCL_CC
- ac_config_files="$ac_config_files Makefile tcl.hpj"
+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
@@ -1280,39 +1729,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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$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
+ :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
+ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
+$as_echo "$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"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
+$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
@@ -1321,63 +1801,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=`$as_echo "$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
@@ -1385,12 +1857,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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
+$as_echo "$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.
@@ -1400,81 +1874,253 @@ 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
+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
+ # 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
+ 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
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
else
- as_unset=false
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
fi
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; 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
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# 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
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
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
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+
+# 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
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
-done
+ $as_echo "$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_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_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 ||
+$as_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'
@@ -1482,148 +2128,111 @@ 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= ;;
+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
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
else
- as_expr=false
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
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
+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=`$as_echo "$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 ||
+$as_echo 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'"
@@ -1632,31 +2241,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
-
+# values after options handling.
+ac_log="
This file was extended by $as_me, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
@@ -1664,124 +2262,116 @@ 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
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
config.status
-configured by $0, generated by GNU Autoconf 2.59,
- with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"
+configured by $0, generated by GNU Autoconf 2.69,
+ with options \\"\$ac_cs_config\\"
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2012 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 )
+ $as_echo "$ac_cs_version"; exit ;;
+ --config | --confi | --conf | --con | --co | --c )
+ $as_echo "$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=`$as_echo "$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 )
+ $as_echo "$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
@@ -1795,31 +2385,45 @@ 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
+ \$as_echo "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
+ $as_echo "$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" ;;
- "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; }; };;
+ case $ac_config_target in
+ "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "tcl.hpj") CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;;
+
+ *) 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
@@ -1829,323 +2433,414 @@ if $ac_need_defaults; then
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,@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
+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=`$as_echo "$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 '`
+ $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
+ `' by configure.'
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
+$as_echo "$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=`$as_echo "$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 ||
+$as_echo 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$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@*)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+$as_echo "$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"; } &&
+ { $as_echo "$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
+$as_echo "$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.
@@ -2165,6 +2860,10 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
+$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
diff --git a/tools/configure.in b/tools/configure.ac
index 6aebcaa..3caa141 100644
--- a/tools/configure.in
+++ b/tools/configure.ac
@@ -2,7 +2,7 @@ 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(man2tcl.c)
-AC_PREREQ(2.59)
+AC_PREREQ(2.69)
# Recover information that Tcl computed with its configure script.
@@ -11,7 +11,7 @@ AC_PREREQ(2.59)
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
-DEF_VER=8.6
+DEF_VER=8.7
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
diff --git a/tools/fix_tommath_h.tcl b/tools/fix_tommath_h.tcl
deleted file mode 100755
index 04bf857..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 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.
-#----------------------------------------------------------------------
-
-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 4516010..a4a73ba 100644
--- a/tools/genStubs.tcl
+++ b/tools/genStubs.tcl
@@ -479,6 +479,8 @@ proc genStubs::makeDecl {name decl index} {
if {[info exists stubs($name,deprecated,$index)]} {
append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n"
set line "$rtype"
+ } elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
+ set line "$scspec [string trim [string range $rtype 0 end-6]]"
} else {
set line "$scspec $rtype"
}
@@ -550,6 +552,9 @@ proc genStubs::makeDecl {name decl index} {
append line ")"
}
}
+ if {[string range $rtype end-5 end] eq "MP_WUR"} {
+ append line " MP_WUR"
+ }
return "$text$line;\n"
}
@@ -613,6 +618,8 @@ proc genStubs::makeSlot {name decl index} {
append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
+ } elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
+ append text [string trim [string range $rtype 0 end-6]] " (*" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
@@ -650,6 +657,9 @@ proc genStubs::makeSlot {name decl index} {
}
}
+ if {[string range $rtype end-5 end] eq "MP_WUR"} {
+ append text " MP_WUR"
+ }
append text "; /* $index */\n"
return $text
}
diff --git a/tools/installVfs.tcl b/tools/installVfs.tcl
new file mode 100644
index 0000000..ad1f5c7
--- /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 (c) 2018 by 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 021ced3..e07b126 100755
--- a/tools/loadICU.tcl
+++ b/tools/loadICU.tcl
@@ -27,6 +27,9 @@
# 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..e9b7ed1
--- /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 (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.
+
+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 {[^\u0020-\u007e]} [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 == -1 || $to == -1 || $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/mkVfs.tcl b/tools/mkVfs.tcl
new file mode 100644
index 0000000..cbfb81e
--- /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 0644
+ } else {
+ file attributes [file join $d2 $ftail] -readonly 1
+ }
+ }
+ }
+
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes $d2 -permissions 0755
+ } 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/tcl.hpj.in b/tools/tcl.hpj.in
index a94cea6..08d411d 100644
--- a/tools/tcl.hpj.in
+++ b/tools/tcl.hpj.in
@@ -5,9 +5,9 @@ HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
+CNT=tcl87.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl86.hlp
+HLP=tcl87.hlp
[FILES]
tcl.rtf
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
new file mode 100644
index 0000000..5e0145f
--- /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 (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.
+
+::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 {}} {body {}}} {
+ # 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 $body
+ }
+ # 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/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index 65d81de..b38f0b5 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -156,8 +156,15 @@ proc process-text {text} {
{\fP} {\fR} \
{\.} . \
{\(bu} "&#8226;" \
- {\*(qo} "&ocirc;" \
]
+ # This might make a few invalid mappings, but we don't use them
+ foreach c {a e i o u y A E I O U Y} {
+ foreach {prefix suffix} {
+ o ring / slash : uml ' acute ^ circ ` grave
+ } {
+ lappend charmap "\\\[${prefix}${c}\]" "&${c}${suffix};"
+ }
+ }
lappend charmap {\-\|\-} -- ; # two hyphens
lappend charmap {\-} - ; # a hyphen
@@ -1559,6 +1566,10 @@ proc make-manpage-section {outputDir sectionDescriptor} {
puts stderr ""
}
+ if {![llength $manual(wing-toc)]} {
+ fatal "not table of contents."
+ }
+
#
# make the wing table of contents for the section
#
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index d607905..517360b 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -4,7 +4,7 @@ if {[catch {package require Tcl 8.6-} msg]} {
puts stderr "ERROR: $msg"
puts stderr "If running this script from 'make html', set the\
NATIVE_TCLSH environment\nvariable to point to an installed\
- tclsh8.6 (or the equivalent tclsh86.exe\non Windows)."
+ tclsh8.7 (or the equivalent tclsh87.exe\non Windows)."
exit 1
}
@@ -22,7 +22,7 @@ if {[catch {package require Tcl 8.6-} msg]} {
# Copyright (c) 1995-1997 Roger E. Critchlow Jr
# Copyright (c) 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] \
+ {^#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,22 +165,40 @@ 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 $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 $tcldir 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
}
@@ -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 "/"
@@ -586,6 +658,7 @@ array set exclude_refs_map {
scrollbar.n {set}
selection.n {string}
tcltest.n {error}
+ text.n {bind image lower raise}
tkvars.n {tk}
tkwait.n {variable}
tm.n {exec}
@@ -667,11 +740,7 @@ try {
# ... but try to extract (name, version) from subdir contents
try {
- try {
- set f [open [file join $pkgsDir $dir configure.in]]
- } trap {POSIX ENOENT} {} {
- set f [open [file join $pkgsDir $dir configure.ac]]
- }
+ set f [open [file join $pkgsDir $dir configure.ac]]
foreach line [split [read $f] \n] {
if {2 == [scan $line \
{ AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} {
diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c
index 40004b1..7a599e0 100644
--- a/tools/tsdPerf.c
+++ b/tools/tsdPerf.c
@@ -5,21 +5,21 @@ extern DLLEXPORT Tcl_PackageInitProc 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,14 +33,14 @@ 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;
}
int
Tsdperf_Init(Tcl_Interp *interp) {
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 5a023e2..21967bd 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -87,7 +87,7 @@ HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR)
CONFIG_INSTALL_DIR = $(INSTALL_ROOT)$(libdir)
# Directory in which to install bundled packages:
-PACKAGE_DIR = @PACKAGE_DIR@
+PACKAGE_DIR = @PACKAGE_DIR@
# Package search path.
TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@
@@ -150,8 +150,8 @@ SHELL = @MAKEFILE_SHELL@
# around; better to use the install-sh script that comes with the
# distribution, which is slower but guaranteed to work.
-INSTALL_STRIP_PROGRAM = -s
-INSTALL_STRIP_LIBRARY = -S -x
+INSTALL_STRIP_PROGRAM = -s
+INSTALL_STRIP_LIBRARY = -S -x
INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c
INSTALL_PROGRAM = ${INSTALL}
@@ -170,7 +170,7 @@ 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.
@@ -227,7 +227,6 @@ SRC_DIR = @srcdir@
TOP_DIR = @TCL_SRC_DIR@
BUILD_DIR = @builddir@
GENERIC_DIR = $(TOP_DIR)/generic
-TOMMATH_DIR = $(TOP_DIR)/libtommath
COMPAT_DIR = $(TOP_DIR)/compat
TOOL_DIR = $(TOP_DIR)/tools
UNIX_DIR = $(TOP_DIR)/unix
@@ -240,13 +239,17 @@ 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@
+
#CC = purify -best-effort @CC@ -DPURIFY
# Flags to be passed to installManPage to control how the manpages should be
# installed (symlinks, compression, package name suffix).
-MAN_FLAGS = @MAN_FLAGS@
+MAN_FLAGS = @MAN_FLAGS@
# If non-empty, install the timezone files that are included with Tcl,
# otherwise use the ones that ship with the OS.
@@ -259,21 +262,23 @@ INSTALL_TZDATA = @INSTALL_TZDATA@
#--------------------------------------------------------------------------
GDB = gdb
+LLDB = lldb
TRACE = strace
TRACE_OPTS =
VALGRIND = valgrind
VALGRINDARGS = --tool=memcheck --num-callers=24 \
- --leak-resolution=high --leak-check=yes --show-reachable=yes -v \
- --suppressions=$(TOOL_DIR)/valgrind_suppress
+ --leak-resolution=high --leak-check=yes --show-reachable=yes -v \
+ --suppressions=$(TOOL_DIR)/valgrind_suppress
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
-STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
--I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
-${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
+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@
CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
@@ -282,7 +287,7 @@ APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
-${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
+ ${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
@@ -305,12 +310,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
@@ -322,15 +327,17 @@ 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_radix_size.o bn_mp_radix_smap.o \
- bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o \
- bn_mp_shrink.o \
+ bn_mp_radix_size.o bn_mp_radix_smap.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 \
@@ -348,7 +355,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
@@ -362,7 +369,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} ${TOMMATH_OBJS} @DTRACE_OBJ@ @ZLIB_OBJS@
+OBJS = ${TCL_OBJS} @DTRACE_OBJ@ @ZLIB_OBJS@ @TOMMATH_OBJS@
TCL_DECLS = \
$(GENERIC_DIR)/tcl.decls \
@@ -447,6 +454,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 \
@@ -466,7 +474,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 \
@@ -660,7 +669,9 @@ UNIX_SRCS = \
$(UNIX_DIR)/tclUnixCompat.c
NOTIFY_SRCS = \
- $(UNIX_DIR)/tclUnixNotfy.c
+ $(UNIX_DIR)/tclEpollNotfy.c \
+ $(UNIX_DIR)/tclKqueueNotfy.c \
+ $(UNIX_DIR)/tclSelectNotfy.c
DL_SRCS = \
$(UNIX_DIR)/tclLoadAix.c \
@@ -701,8 +712,46 @@ ZLIB_SRCS = \
# won't compile on the current machine, and they will cause problems for
# things like "make depend".
-SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \
- $(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@
+SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(NOTIFY_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@
+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
@@ -716,15 +765,41 @@ 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}/reg
+ @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 \
+ cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
+ ${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@
@@ -754,13 +829,14 @@ Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
clean: clean-packages
rm -rf *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
- errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@
- cd dltest ; $(MAKE) clean
+ errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl @DTRACE_HDR@ \
+ minizip${HOST_EXEEXT} *.${HOST_OBJEXT} *.zip *.vfs
+ (cd dltest ; $(MAKE) clean)
distclean: distclean-packages clean
rm -rf Makefile config.status config.cache config.log tclConfig.sh \
tclConfig.h *.plist Tcl.framework tcl.pc
- cd dltest ; $(MAKE) distclean
+ (cd dltest ; $(MAKE) distclean)
depend:
makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)
@@ -815,7 +891,14 @@ gdb-test: ${TCLTEST_EXE}
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
$(GDB) ./${TCLTEST_EXE} --command=gdb.run
- rm gdb.run
+ @rm gdb.run
+
+lldb-test: ${TCLTEST_EXE}
+ @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run
+ @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run
+ $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl \
+ $(TESTFLAGS) -singleproc 1
+ @rm lldb.run
# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
@@ -849,7 +932,9 @@ gdb: ${TCL_EXE}
$(SHELL_ENV) $(GDB) ./${TCL_EXE}
valgrind: ${TCL_EXE} ${TCLTEST_EXE}
- $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind $(TESTFLAGS)
+ $(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \
+ $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \
+ $(TESTFLAGS)
valgrindshell: ${TCL_EXE}
$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCL_EXE} $(SCRIPT)
@@ -864,7 +949,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
@@ -876,19 +961,16 @@ install: $(INSTALL_TARGETS)
install-strip:
$(MAKE) $(INSTALL_TARGETS) \
- INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
- INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}"
+ INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}"
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" \
- "$(CONFIG_INSTALL_DIR)"; \
- do \
+ "$(CONFIG_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
- else true; \
- fi; \
- done;
+ fi; \
+ done
@echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/"
@@INSTALL_LIB@
@chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)"
@@ -908,92 +990,105 @@ install-binaries: binaries
@$(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/pkgconfig"
@$(INSTALL_DATA) tcl.pc "$(LIB_INSTALL_DIR)/pkgconfig/tcl.pc"
+install-libraries-zipfs-shared: libraries
+ @for i in "$(SCRIPT_INSTALL_DIR)"; do \
+ if [ ! -d "$$i" ] ; then \
+ echo "Making directory $$i"; \
+ $(INSTALL_DATA_DIR) "$$i"; \
+ fi; \
+ done
+ @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
+ @for i in $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; do \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
+ done
+
+install-libraries-zipfs-static: install-libraries-zipfs-shared
+ $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
+
install-libraries: libraries
@for i in "$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
- else true; \
- fi; \
- done;
- @for i in opt0.4 http1.0 encoding; \
- do \
+ fi; \
+ done
+ @for i in opt0.4 cookiejar0.2 encoding; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
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"; \
$(INSTALL_DATA_DIR) "$(MODULE_INSTALL_DIR)/$$i"; \
- else true; \
- fi; \
- done;
- @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/";
+ fi; \
+ done
+ @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
- $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \
- do \
+ $(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 ; \
- do \
- $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/http1.0"; \
- done;
- @echo "Installing package http 2.9.2 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm";
- @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
- @for i in $(TOP_DIR)/library/opt/*.tcl ; \
- do \
+ done
+ @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/"
+ @for i in $(TOP_DIR)/library/cookiejar/*.tcl; do \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
+ done
+ @for i in $(TOP_DIR)/library/cookiejar/*.gz; do \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
+ done
+ @echo "Installing package http 2.9.2 as a Tcl Module"
+ @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
+ "$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm"
+ @echo "Installing package opt 0.4.7"
+ @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";
- @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm";
- @echo "Installing package tcltest 2.5.3 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm";
-
- @echo "Installing package platform 1.0.14 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.14.tm";
- @echo "Installing package platform::shell 1.1.4 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm";
-
- @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";
- @for i in $(TOP_DIR)/library/encoding/*.enc ; do \
+ done
+ @echo "Installing package msgcat 1.7.1 as a Tcl Module"
+ @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
+ "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm"
+ @echo "Installing package tcltest 2.5.3 as a Tcl Module"
+ @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
+ "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm"
+ @echo "Installing package platform 1.0.14 as a Tcl Module"
+ @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
+ "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.14.tm"
+ @echo "Installing package platform::shell 1.1.4 as a Tcl Module"
+ @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
+ "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm"
+ @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
+ @for i in $(TOP_DIR)/library/encoding/*.enc; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \
- done;
- @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \
+ done
+ @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \
echo "Customizing tcl module path"; \
echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \
"$(SCRIPT_INSTALL_DIR)/tm.tcl"; \
fi
install-tzdata:
- @for i in tzdata; \
- do \
+ @for i in tzdata; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
- else true; \
- fi; \
- done;
+ fi; \
+ done
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
- @for i in $(TOP_DIR)/library/tzdata/* ; do \
+ @for i in $(TOP_DIR)/library/tzdata/*; do \
if [ -d $$i ] ; then \
ii=`basename $$i`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \
fi; \
- for j in $$i/* ; do \
+ for j in $$i/*; do \
if [ -d $$j ] ; then \
jj=`basename $$j`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
fi; \
- for k in $$j/* ; do \
+ for k in $$j/*; do \
$(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
done; \
else \
@@ -1003,86 +1098,80 @@ install-tzdata:
else \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/tzdata"; \
fi; \
- done;
+ done
install-msgs:
- @for i in msgs; \
- do \
+ @for i in msgs; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
- else true; \
- fi; \
- done;
+ fi; \
+ done
@echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/"
- @for i in $(TOP_DIR)/library/msgs/*.msg ; do \
- $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \
- done;
+ @for i in $(TOP_DIR)/library/msgs/*.msg; do \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \
+ done
install-doc: doc
- @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \
- do \
+ @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
- else true; \
- fi; \
- done;
- @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/";
+ fi; \
+ done
+ @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"
@for i in $(TOP_DIR)/doc/*.1; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \
done
-
- @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/";
+ @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"
@for i in $(TOP_DIR)/doc/*.3; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \
done
-
@echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/";
@for i in $(TOP_DIR)/doc/*.n; do \
$(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 \
+ @for i in "$(INCLUDE_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
- else true; \
- fi; \
- done;
+ 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;
+ done
# Optional target to install private headers
install-private-headers:
- @for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
- do \
+ @for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
- else true; \
- fi; \
- done;
+ 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;
+ done
@if test -f tclConfig.h; then\
$(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
- fi;
+ fi
#--------------------------------------------------------------------------
# Rules for how to compile C files
@@ -1101,42 +1190,45 @@ tclTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
@if test -f tclAppInit.o ; then \
rm -f tclAppInit.sav; \
mv tclAppInit.o tclAppInit.sav; \
- fi;
+ fi
$(CC) -c $(APP_CC_SWITCHES) \
-DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \
-DTCL_TEST $(UNIX_DIR)/tclAppInit.c
- rm -f tclTestInit.o
+ @rm -f tclTestInit.o
mv tclAppInit.o tclTestInit.o
@if test -f tclAppInit.sav ; then \
mv tclAppInit.sav tclAppInit.o; \
- fi;
+ fi
xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
@if test -f tclAppInit.o ; then \
rm -f tclAppInit.sav; \
mv tclAppInit.o tclAppInit.sav; \
- fi;
+ fi
$(CC) -c $(APP_CC_SWITCHES) \
-DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \
-DTCL_TEST -DTCL_XT_TEST $(UNIX_DIR)/tclAppInit.c
- rm -f xtTestInit.o
+ @rm -f xtTestInit.o
mv tclAppInit.o xtTestInit.o
@if test -f tclAppInit.sav ; then \
mv tclAppInit.sav tclAppInit.o; \
- fi;
+ fi
# Object files used on all Unix systems:
-REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \
- $(GENERIC_DIR)/regcustom.h
-TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h
-COMPILEHDR=$(GENERIC_DIR)/tclCompile.h
-FSHDR=$(GENERIC_DIR)/tclFileSystem.h
-IOHDR=$(GENERIC_DIR)/tclIO.h
-MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h
-PARSEHDR=$(GENERIC_DIR)/tclParse.h
-NREHDR=$(GENERIC_DIR)/tclInt.h
-TRIMHDR=$(GENERIC_DIR)/tclStringTrim.h
+REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \
+ $(GENERIC_DIR)/regcustom.h
+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)/tclTomMathDecls.h
+PARSEHDR = $(GENERIC_DIR)/tclParse.h
+NREHDR = $(GENERIC_DIR)/tclInt.h
+TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
+
+TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
+ -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
@@ -1320,7 +1412,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
@@ -1365,19 +1457,19 @@ tclPkg.o: $(GENERIC_DIR)/tclPkg.c
# prefix/exec_prefix but all the different paths individually.
tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c
- $(CC) -c $(CC_SWITCHES) \
+ $(CC) -c $(CC_SWITCHES) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \
-DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR)\"" \
-DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR)\"" \
- \
-DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \
-DCFG_RUNTIME_BINDIR="\"$(bindir)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \
-DCFG_RUNTIME_INCDIR="\"$(includedir)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir)\"" \
- \
+ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \
+ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
$(GENERIC_DIR)/tclPkgConfig.c
tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c
@@ -1389,6 +1481,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
@@ -1425,6 +1520,15 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c
tclZlib.o: $(GENERIC_DIR)/tclZlib.c
$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c
+tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c
+ $(CC) -c $(CC_SWITCHES) \
+ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \
+ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
+ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \
+ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \
+ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \
+ $(GENERIC_DIR)/tclZipfs.c
+
tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS)
$(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c
@@ -1521,6 +1625,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
@@ -1530,6 +1637,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
@@ -1539,6 +1649,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
@@ -1587,8 +1700,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
@@ -1653,8 +1769,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
+ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclEpollNotfy.c
+
+tclKqueueNotfy.o: $(UNIX_DIR)/tclKqueueNotfy.c
+ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclKqueueNotfy.c
+
+tclSelectNotfy.o: $(UNIX_DIR)/tclSelectNotfy.c
+ $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclSelectNotfy.c
tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c
@@ -1671,7 +1793,6 @@ tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c
tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c
-TCL_LOCATIONS=-DTCL_LIBRARY="\"${TCL_LIBRARY}\"" -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh
$(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c
@@ -1797,92 +1918,143 @@ 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
configure-packages:
@for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- if [ -x $$i/configure ]; then \
- pkg=`basename $$i`; \
- echo "Configuring package '$$pkg'"; \
- mkdir -p $(PKG_DIR)/$$pkg; \
- if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; \
- $$i/configure --with-tcl=../.. \
- --with-tclinclude=$(GENERIC_DIR) \
- $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \
- --enable-shared --enable-threads; ) || exit $$?; \
- fi; \
+ if [ -d $$i ] ; then \
+ if [ -x $$i/configure ] ; then \
+ pkg=`basename $$i`; \
+ echo "Configuring package '$$pkg'"; \
+ mkdir -p $(PKG_DIR)/$$pkg; \
+ if [ ! -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ ( cd $(PKG_DIR)/$$pkg; \
+ $$i/configure --with-tcl=../.. \
+ --with-tclinclude=$(GENERIC_DIR) \
+ $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \
+ --enable-shared; ) || exit $$?; \
+ fi; \
+ fi; \
fi; \
- fi; \
done
packages: configure-packages ${STUB_LIB_FILE}
@for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- pkg=`basename $$i`; \
- if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- echo "Building package '$$pkg'"; \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \
+ if [ -d $$i ] ; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ echo "Building package '$$pkg'"; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \
+ fi; \
fi; \
- fi; \
done
install-packages: packages
@for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- pkg=`basename $$i`; \
- if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- echo "Installing package '$$pkg'"; \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \
- "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \
+ if [ -d $$i ] ; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ echo "Installing package '$$pkg'"; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \
+ "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \
+ fi; \
fi; \
- fi; \
done
test-packages: ${TCLTEST_EXE} packages
@for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- pkg=`basename $$i`; \
- if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- echo "Testing package '$$pkg'"; \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) \
- "@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \
- "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \
- "TCLLIBPATH=../../pkgs" test \
- "TCLSH_PROG=../../${TCLTEST_EXE}"; ) \
+ if [ -d $$i ] ; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ echo "Testing package '$$pkg'"; \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) \
+ "@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \
+ "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \
+ "TCLLIBPATH=../../pkgs" test \
+ "TCLSH_PROG=../../${TCLTEST_EXE}"; ) \
+ fi; \
fi; \
- fi; \
done
clean-packages:
@for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- pkg=`basename $$i`; \
- if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
+ if [ -d $$i ] ; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
+ fi; \
fi; \
- fi; \
done
distclean-packages:
@for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- pkg=`basename $$i`; \
- if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
+ if [ -d $$i ] ; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
+ fi; \
+ rm -rf $(PKG_DIR)/$$pkg; \
fi; \
- rm -rf $(PKG_DIR)/$$pkg; \
- fi; \
done; \
rm -rf $(PKG_DIR)
@@ -1890,13 +2062,13 @@ dist-packages: configure-packages
@rm -rf $(DISTROOT)/pkgs; \
mkdir -p $(DISTROOT)/pkgs; \
for i in $(PKGS_DIR)/*; do \
- if [ -d $$i ]; then \
- pkg=`basename $$i`; \
- if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \
- ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \
- "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \
+ if [ -d $$i ] ; then \
+ pkg=`basename $$i`; \
+ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
+ ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \
+ "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \
+ fi; \
fi; \
- fi; \
done
#--------------------------------------------------------------------------
@@ -1911,9 +2083,9 @@ dist-packages: configure-packages
gendate:
bison --output-file=$(GENERIC_DIR)/tclDate.c \
- --no-lines \
- --name-prefix=TclDate \
- $(GENERIC_DIR)/tclGetDate.y
+ --no-lines \
+ --name-prefix=TclDate \
+ $(GENERIC_DIR)/tclGetDate.y
# yacc -l $(GENERIC_DIR)/tclGetDate.y
# sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \
@@ -1926,14 +2098,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.
#
@@ -1949,6 +2113,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 \
@@ -1956,6 +2125,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.
@@ -1964,14 +2137,16 @@ genstubs:
checkstubs: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
- | sort -n`; do \
- match=0; \
- for j in $(TCL_DECLS); do \
- if [ `grep -c "$$i *(" $$j` -gt 0 ]; then \
- match=1; \
- fi; \
- done; \
- if [ $$match -eq 0 ]; then echo $$i; fi \
+ | sort -n` ; do \
+ match=0; \
+ for j in $(TCL_DECLS); do \
+ if [ `grep -c "$$i *(" $$j` -gt 0 ] ; then \
+ match=1; \
+ fi; \
+ done; \
+ if [ $$match -eq 0 ] ; then \
+ echo $$i; \
+ fi; \
done
#
@@ -1981,14 +2156,17 @@ checkstubs: $(TCL_LIB_FILE)
checkdoc: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
- | grep -v 'Cmd$$' | sort -n`; do \
- match=0; \
- for j in $(TOP_DIR)/doc/*.3; do \
- if [ `grep '\-' $$j | grep -c $$i` -gt 0 ]; then \
- match=1; \
- fi; \
- done; \
- if [ $$match -eq 0 ]; then echo $$i; fi \
+ | grep -Fv . | grep -v 'Cmd$$' | sort -n`; do \
+ match=0; \
+ i=`echo $$i | sed 's/^_//'`; \
+ for j in $(TOP_DIR)/doc/*.3; do \
+ if [ `grep '\-' $$j | grep -c $$i` -gt 0 ]; then \
+ match=1; \
+ fi; \
+ done; \
+ if [ $$match -eq 0 ]; then \
+ echo $$i; \
+ fi; \
done
#
@@ -1996,7 +2174,7 @@ checkdoc: $(TCL_LIB_FILE)
#
checkuchar:
- -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR
+ -@egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR
#
# Target to make sure that only symbols with "Tcl" prefixes are exported.
@@ -2016,15 +2194,18 @@ checkexports: $(TCL_LIB_FILE)
# system.
#
+RPM_PLATFORMS = i386
rpm: all
- rm -f THIS.TCL.SPEC
+ -@rm -f THIS.TCL.SPEC
echo "%define _builddir `pwd`" > THIS.TCL.SPEC
echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC
cat tcl.spec >> THIS.TCL.SPEC
- mkdir -p RPMS/i386
- rpmbuild -bb THIS.TCL.SPEC
- mv RPMS/i386/*.rpm .
- rm -rf RPMS THIS.TCL.SPEC
+ for platform in $(RPM_PLATFORMS); do \
+ mkdir -p RPMS/$$platform && \
+ rpmbuild -bb THIS.TCL.SPEC && \
+ mv RPMS/$$platform/*.rpm .; \
+ done
+ -rm -rf RPMS THIS.TCL.SPEC
#
# Target to create a proper Tcl distribution from information in the master
@@ -2036,7 +2217,9 @@ DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
-$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4 \
+BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat reg dde tcltest platform
+
+$(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
@@ -2048,21 +2231,22 @@ $(TOP_DIR)/manifest.uuid:
printf "git." >$(TOP_DIR)/manifest.uuid
git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid
-dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid genstubs dist-packages ${NATIVE_TCLSH}
+dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \
+ $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH}
rm -rf $(DISTDIR)
mkdir -p $(DISTDIR)/unix
cp -p $(TOP_DIR)/manifest.uuid $(DISTDIR)
cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
- cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \
+ cp $(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 \
$(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(UNIX_DIR)/tcl.spec \
$(UNIX_DIR)/installManPage $(UNIX_DIR)/tclConfig.h.in \
$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
- chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in
+ chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.ac
chmod 775 $(DISTDIR)/unix/ldAix
@mkdir $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
@@ -2074,19 +2258,19 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
$(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 http1.0 http opt msgcat reg dde tcltest platform; \
- do \
- mkdir $(DISTDIR)/library/$$i ;\
- cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
- done;
+ @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/*.txt.gz $(DISTDIR)/library/cookiejar
@mkdir $(DISTDIR)/library/encoding
cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
@mkdir $(DISTDIR)/library/msgs
cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
@echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata
- @( cd $(TOP_DIR); \
- find library/tzdata -name CVS -prune -o -type f -print ) \
+ @( cd $(TOP_DIR); find library/tzdata -type f -print ) \
| ( cd $(TOP_DIR) ; xargs tar cf - ) \
| ( cd $(DISTDIR) ; tar xfp - )
@mkdir $(DISTDIR)/doc
@@ -2096,8 +2280,8 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \
$(COMPAT_DIR)/README $(DISTDIR)/compat
@mkdir $(DISTDIR)/compat/zlib
- ( cd $(COMPAT_DIR)/zlib; \
- find . -name CVS -prune -o -type f -print ) \
+ @echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib
+ @( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \
| ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
| ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
@mkdir $(DISTDIR)/tests
@@ -2107,7 +2291,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
$(DISTDIR)/tests
@mkdir $(DISTDIR)/win
cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
- cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \
+ cp $(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 \
@@ -2116,7 +2300,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
$(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
@@ -2140,7 +2323,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
$(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)/configure $(TOOL_DIR)/configure.ac \
$(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \
$(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \
$(DISTDIR)/tools
@@ -2155,8 +2338,10 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
alldist: dist
rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME)
- cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \
- gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME)
+ ( cd $(DISTROOT); \
+ tar cf $(DISTNAME)-src.tar $(DISTNAME); \
+ gzip -9 $(DISTNAME)-src.tar; \
+ zip -qr8 $(ZIPNAME) $(DISTNAME) )
#--------------------------------------------------------------------------
# This target creates the HTML folder for Tcl & Tk and places it in
@@ -2185,13 +2370,10 @@ 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)
+ --tcl --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
@@ -2208,6 +2390,7 @@ BUILD_HTML = \
.PHONY: install-tzdata install-msgs
.PHONY: packages configure-packages test-packages clean-packages
.PHONY: dist-packages distclean-packages install-packages
+.PHONY: install-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile
#--------------------------------------------------------------------------
# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/unix/README b/unix/README
index 22b3833..3340dc6 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.
diff --git a/unix/configure b/unix/configure
index 73a8eac..d3a4856 100755
--- a/unix/configure
+++ b/unix/configure
@@ -1,81 +1,459 @@
#! /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.69 for tcl 8.7.
+#
+#
+# Copyright (C) 1992-1996, 1998-2012 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
+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
+ # 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
+ 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
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
+else
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
fi
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; 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
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# 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
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
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
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+# 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'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+as_fn_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="if test -n \"\${ZSH_VERSION+set}\" && (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
+ 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
+ exitcode=1; echo positional parameters were not saved.
+fi
+test x\$exitcode = x0 || 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_have_required=no
+fi
+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then :
+
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+as_found=false
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
do
- if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
- eval $as_var=C; export $as_var
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ CONFIG_SHELL=$as_shell as_have_required=yes
+ if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ break 2
+fi
+fi
+ done;;
+ esac
+ as_found=false
+done
+$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then :
+ CONFIG_SHELL=$SHELL as_have_required=yes
+fi; }
+IFS=$as_save_IFS
+
+
+ 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'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
+fi
+
+ if test x$as_have_required = xno; then :
+ $as_echo "$0: This script requires a shell more modern than all"
+ $as_echo "$0: the shells that I found on your system."
+ if test x${ZSH_VERSION+set} = xset ; then
+ $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should"
+ $as_echo "$0: be upgraded to zsh 4.3.4 or later."
else
- $as_unset $as_var
+ $as_echo "$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
-done
+ 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
-# 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_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=`$as_echo "$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 ||
+$as_echo 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_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_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+
+# 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
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ $as_echo "$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 ||
+$as_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'
@@ -83,146 +461,91 @@ 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" ||
+ { $as_echo "$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= ;;
+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
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
else
- as_expr=false
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
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
+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 +554,253 @@ 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
+#ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>
#endif
-#if HAVE_SYS_STAT_H
+#ifdef HAVE_SYS_STAT_H
# include <sys/stat.h>
#endif
-#if STDC_HEADERS
+#ifdef STDC_HEADERS
# include <stdlib.h>
# include <stddef.h>
#else
-# if HAVE_STDLIB_H
+# ifdef HAVE_STDLIB_H
# include <stdlib.h>
# endif
#endif
-#if HAVE_STRING_H
-# if !STDC_HEADERS && HAVE_MEMORY_H
+#ifdef HAVE_STRING_H
+# if !defined STDC_HEADERS && defined HAVE_MEMORY_H
# include <memory.h>
# endif
# include <string.h>
#endif
-#if HAVE_STRINGS_H
+#ifdef HAVE_STRINGS_H
# include <strings.h>
#endif
-#if HAVE_INTTYPES_H
+#ifdef HAVE_INTTYPES_H
# include <inttypes.h>
-#else
-# if HAVE_STDINT_H
-# include <stdint.h>
-# endif
#endif
-#if HAVE_UNISTD_H
+#ifdef HAVE_STDINT_H
+# include <stdint.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 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 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_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
+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_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
+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_zipfs
+enable_framework
+'
+ 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 +823,49 @@ 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'
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[^=]*=\(.*\)'`
+ case $ac_option in
+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *=) ac_optarg= ;;
+ *) ac_optarg=yes ;;
+ esac
# Accept the important Cygnus configure options, so we can diagnose typos.
- case $ac_option in
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
@@ -385,33 +887,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=`$as_echo "$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=`$as_echo "$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 +966,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 +996,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,6 +1070,16 @@ 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 ;;
@@ -583,26 +1130,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=`$as_echo "$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=`$as_echo "$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 +1179,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
+ $as_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}
+ $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
@@ -650,31 +1206,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" ;;
+ *) $as_echo "$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
do
- eval ac_val=$`echo $ac_var`
+ eval ac_val=\$$ac_var
+ # Remove trailing slashes.
+ case $ac_val in
+ */ )
+ 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
- [\\/$]* | ?:[\\/]* ) ;;
- *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
- { (exit 1); exit 1; }; };;
+ [\\/$]* | ?:[\\/]* ) 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 +1249,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 +1260,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 ||
+$as_echo 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 +1334,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 +1348,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 +1368,25 @@ 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]
+ --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 +1395,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 +1410,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)
@@ -861,6 +1422,7 @@ Optional Features:
startup, otherwise use old heuristic (default: on)
--enable-dll-unloading enable the 'unload' command (default: on)
--enable-dtrace build with DTrace support (default: off)
+ --enable-zipfs build with Zipfs support (default: on)
--enable-framework package shared libraries in MacOSX frameworks
(default: off)
@@ -869,6 +1431,9 @@ Optional Packages:
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--with-encoding encoding for configuration values (default:
iso8859-1)
+ --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 +1441,606 @@ 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$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 guested 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
else
- echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi
- cd $ac_popdir
+ $as_echo "$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.69
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2012 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
+ 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\""
+$as_echo "$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
+ $as_echo "$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_echo "$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$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\""
+$as_echo "$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
+ $as_echo "$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_echo "$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_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\""
+$as_echo "$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
+ $as_echo "$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_echo "$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_header_mongrel LINENO HEADER VAR INCLUDES
+# -------------------------------------------------------
+# Tests whether HEADER exists, giving a warning if it cannot be compiled using
+# the include files in INCLUDES and setting the cache variable VAR
+# accordingly.
+ac_fn_c_check_header_mongrel ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if eval \${$3+:} false; then :
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+else
+ # Is the header compilable?
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5
+$as_echo_n "checking $2 usability... " >&6; }
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+#include <$2>
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ ac_header_compiler=yes
+else
+ ac_header_compiler=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5
+$as_echo "$ac_header_compiler" >&6; }
+
+# Is the header present?
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5
+$as_echo_n "checking $2 presence... " >&6; }
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <$2>
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"; then :
+ ac_header_preproc=yes
+else
+ ac_header_preproc=no
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5
+$as_echo "$ac_header_preproc" >&6; }
+
+# So? What about this header?
+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #((
+ yes:no: )
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5
+$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5
+$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;}
+ ;;
+ no:yes:* )
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5
+$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5
+$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5
+$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5
+$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5
+$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;}
+ ;;
+esac
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ eval "$3=\$ac_header_compiler"
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_header_mongrel
+
+# ac_fn_c_try_run LINENO
+# ----------------------
+# Try to link 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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: program exited with status $ac_status" >&5
+ $as_echo "$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_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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_header_compile
+
+# 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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.
+ 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 $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 ()
+{
+return $2 ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ eval "$3=yes"
+else
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_func
+
+# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES
+# ---------------------------------------------
+# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR
+# accordingly.
+ac_fn_c_check_decl ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ as_decl_name=`echo $2|sed 's/ *(.*//'`
+ as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5
+$as_echo_n "checking whether $as_decl_name is declared... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main ()
+{
+#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
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ eval "$3=no"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main ()
+{
+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 ()
+{
+if (sizeof (($2)))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+
+else
+ eval "$3=yes"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_type
+
+# 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5
+$as_echo_n "checking for $2.$3... " >&6; }
+if eval \${$4+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$5
+int
+main ()
+{
+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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$5
+int
+main ()
+{
+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
+ eval "$4=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$4
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_member
+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.69. Invocation command line was
$ $0 $@
_ACEOF
+exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
@@ -1016,7 +2059,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`
@@ -1028,8 +2071,9 @@ for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
- echo "PATH: $as_dir"
-done
+ $as_echo "PATH: $as_dir"
+ done
+IFS=$as_save_IFS
} >&5
@@ -1051,7 +2095,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 +2105,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=`$as_echo "$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,104 +2127,115 @@ 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=$?
# Save into config.log some information that might help in debugging.
{
echo
- cat <<\_ASBOX
-## ---------------- ##
+ $as_echo "## ---------------- ##
## 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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$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
-## ----------------- ##
+ $as_echo "## ----------------- ##
## 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=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
- cat <<\_ASBOX
-## ------------- ##
-## Output files. ##
-## ------------- ##
-_ASBOX
+ $as_echo "## ------------------- ##
+## 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=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
- cat <<\_ASBOX
-## ----------- ##
+ $as_echo "## ----------- ##
## 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"
+ $as_echo "$as_me: caught signal $ac_signal"
+ $as_echo "$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
+rm -f -r conftest* confdefs.h
+
+$as_echo "/* confdefs.h */" > confdefs.h
# Predefined preprocessor variables.
@@ -1189,112 +2243,137 @@ 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
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_URL "$PACKAGE_URL"
+_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
+# Prefer an explicitly selected file to automatically selected ones.
+ac_site_file1=NONE
+ac_site_file2=NONE
+if test -n "$CONFIG_SITE"; then
+ # We do not want a PATH search for config.site.
+ case $CONFIG_SITE in #((
+ -*) ac_site_file1=./$CONFIG_SITE;;
+ */*) ac_site_file1=$CONFIG_SITE;;
+ *) ac_site_file1=./$CONFIG_SITE;;
+ esac
+elif test "x$prefix" != xNONE; then
+ ac_site_file1=$prefix/share/config.site
+ ac_site_file2=$prefix/etc/config.site
+else
+ ac_site_file1=$ac_default_prefix/share/config.site
+ ac_site_file2=$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_file1" "$ac_site_file2"
+do
+ test "x$ac_site_file" = xNONE && continue
+ if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
+$as_echo "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file"
+ . "$ac_site_file" \
+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
+$as_echo "$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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
+$as_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
+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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+$as_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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
+$as_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=:
+ # 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
+$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ ac_cache_corrupted=:
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
+$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
+ eval $ac_var=\$ac_old_val
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
+$as_echo "$as_me: former value: \`$ac_old_val'" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
+$as_echo "$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=`$as_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'" ;;
+ *) 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; }; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
+$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ as_fn_error $? "run \`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 +2386,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=".10"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a4"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
@@ -1382,62 +2436,60 @@ 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"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use symlinks for manpages" >&5
+$as_echo_n "checking whether to use symlinks for manpages... " >&6; }
+ # Check whether --enable-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
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
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
+$as_echo "$enableval" >&6; }
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to compress the manpages" >&5
+$as_echo_n "checking whether to compress the manpages... " >&6; }
+ # Check whether --enable-man-compression was given.
+if test "${enable_man_compression+set}" = set; 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
enableval="no"
-fi;
- echo "$as_me:$LINENO: result: $enableval" >&5
-echo "${ECHO_T}$enableval" >&6
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for compressed file suffix" >&5
+$as_echo_n "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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $Z" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to add a package name suffix for the manpages" >&5
+$as_echo_n "checking whether to add a package name suffix for the manpages... " >&6; }
+ # Check whether --enable-man-suffix was given.
+if test "${enable_man_suffix+set}" = set; 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
enableval="no"
-fi;
- echo "$as_me:$LINENO: result: $enableval" >&5
-echo "${ECHO_T}$enableval" >&6
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
+$as_echo "$enableval" >&6; }
@@ -1460,10 +2512,10 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1473,35 +2525,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
@@ -1511,39 +2565,50 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+$as_echo "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1553,77 +2618,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1634,18 +2659,19 @@ 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
+ 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
+ $as_echo "$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.
@@ -1663,24 +2689,25 @@ fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1690,39 +2717,41 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
@@ -1732,66 +2761,78 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+$as_echo "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
fi
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; }; }
+test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+$as_echo "$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; 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\""
+$as_echo "$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
+ $as_echo "$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
@@ -1803,112 +2844,108 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
+$as_echo_n "checking whether the C compiler works... " >&6; }
+ac_link_default=`$as_echo "$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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link_default") 2>&5
+ ac_status=$?
+ $as_echo "$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+set}" = set && 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
+test "$ac_cv_exeext" = no && ac_cv_exeext=
+
else
- echo "$as_me: failed program was:" >&5
+ ac_file=''
+fi
+if test -z "$ac_file"; then :
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+$as_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; }; }
+{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
fi
-
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
+$as_echo_n "checking for C compiler default output file name... " >&6; }
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
+$as_echo_n "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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
+ $as_echo "$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,38 +2953,90 @@ 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; }; }
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
+$as_echo "$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 ()
+{
+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.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
+$as_echo_n "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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ $as_echo "$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
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details" "$LINENO" 5; }
+ fi
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
+$as_echo "$cross_compiling" >&6; }
+
+rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
+ac_clean_files=$ac_clean_files_save
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
+$as_echo_n "checking for suffix of object files... " >&6; }
+if ${ac_cv_objext+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
@@ -1959,45 +3048,46 @@ 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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_compile") 2>&5
+ ac_status=$?
+ $as_echo "$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
+ $as_echo "$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; }; }
+{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5
+$as_echo_n "checking whether we are using the GNU C compiler... " >&6; }
+if ${ac_cv_c_compiler_gnu+:} false; then :
+ $as_echo_n "(cached) " >&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. */
int
@@ -2011,55 +3101,34 @@ 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
+ ac_compiler_gnu=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext 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`
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
+$as_echo "$ac_cv_c_compiler_gnu" >&6; }
+if test $ac_compiler_gnu = yes; then
+ GCC=yes
+else
+ GCC=
+fi
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
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
+$as_echo_n "checking whether $CC accepts -g... " >&6; }
+if ${ac_cv_prog_cc_g+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
@@ -2070,39 +3139,49 @@ 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_cv_prog_cc_g=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ CFLAGS=""
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+
+else
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main ()
+{
-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 core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
-echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
+$as_echo "$ac_cv_prog_cc_g" >&6; }
if test "$ac_test_CFLAGS" = set; then
CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
@@ -2118,23 +3197,18 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5
+$as_echo_n "checking for $CC option to accept ISO C89... " >&6; }
+if ${ac_cv_prog_cc_c89+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- ac_cv_prog_cc_stdc=no
+ ac_cv_prog_cc_c89=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>
+struct stat;
/* 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);
@@ -2157,12 +3231,17 @@ static char *f (char * (*g) (char **, int), char **p, ...)
/* 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
+ as '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's necessary to write '\x00'==0 to get something
- that's true only with -std1. */
+ that's 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);};
@@ -2177,205 +3256,37 @@ return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
return 0;
}
_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 '' -qlanglvl=extc89 -qlanglvl=ansi -std \
+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
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_c89=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext
+rm -f core conftest.err conftest.$ac_objext
+ test "x$ac_cv_prog_cc_c89" != "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 ;;
+# AC_CACHE_VAL
+case "x$ac_cv_prog_cc_c89" in
+ x)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+$as_echo "none needed" >&6; } ;;
+ xno)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+$as_echo "unsupported" >&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" ;;
+ CC="$CC $ac_cv_prog_cc_c89"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
+$as_echo "$ac_cv_prog_cc_c89" >&6; } ;;
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
-/* end confdefs.h. */
-$ac_declaration
-#include <stdlib.h>
-int
-main ()
-{
-exit (42);
- ;
- 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
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-continue
-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
-/* end confdefs.h. */
-$ac_declaration
-int
-main ()
-{
-exit (42);
- ;
- 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
- break
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+if test "x$ac_cv_prog_cc_c89" != xno; then :
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-done
-rm -f conftest*
-if test -n "$ac_declaration"; then
- echo '#ifdef __cplusplus' >>confdefs.h
- echo $ac_declaration >>confdefs.h
- echo '#endif' >>confdefs.h
-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
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
@@ -2383,18 +3294,14 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
+$as_echo_n "checking for inline... " >&6; }
+if ${ac_cv_c_inline+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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;
@@ -2403,41 +3310,16 @@ $ac_kw foo_t foo () {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.$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
-
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
+$as_echo "$ac_cv_c_inline" >&6; }
case $ac_cv_c_inline in
inline | yes) ;;
@@ -2455,10 +3337,11 @@ _ACEOF
esac
+
#--------------------------------------------------------------------
# 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
# Do this early, otherwise an autoconf bug throws errors on configure
@@ -2469,15 +3352,15 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
+$as_echo_n "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
+ if ${ac_cv_prog_CPP+:} false; then :
+ $as_echo_n "(cached) " >&6
else
# Double quotes because CPP needs to be expanded
for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"
@@ -2491,11 +3374,7 @@ do
# <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>
@@ -2504,78 +3383,34 @@ cat >>conftest.$ac_ext <<_ACEOF
#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
+if ac_fn_c_try_cpp "$LINENO"; then :
+else
# 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
-
# 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,8 +3422,8 @@ fi
else
ac_cv_prog_CPP=$CPP
fi
-echo "$as_me:$LINENO: result: $CPP" >&5
-echo "${ECHO_T}$CPP" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
+$as_echo "$CPP" >&6; }
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
@@ -2598,11 +3433,7 @@ do
# <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>
@@ -2611,85 +3442,40 @@ cat >>conftest.$ac_ext <<_ACEOF
#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
+if ac_fn_c_try_cpp "$LINENO"; then :
+else
# 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
-
# 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 :
+
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; }; }
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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,31 +3485,142 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
+$as_echo_n "checking for grep that handles long lines and -e... " >&6; }
+if ${ac_cv_path_GREP+:} false; then :
+ $as_echo_n "(cached) " >&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'
+ 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
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo '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
-echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5
-echo "${ECHO_T}$ac_cv_prog_egrep" >&6
- EGREP=$ac_cv_prog_egrep
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
+$as_echo "$ac_cv_path_GREP" >&6; }
+ GREP="$ac_cv_path_GREP"
-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
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
+$as_echo_n "checking for egrep... " >&6; }
+if ${ac_cv_path_EGREP+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ 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
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo '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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
+$as_echo "$ac_cv_path_EGREP" >&6; }
+ EGREP="$ac_cv_path_EGREP"
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5
+$as_echo_n "checking for ANSI C header files... " >&6; }
+if ${ac_cv_header_stdc+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <stdarg.h>
@@ -2738,51 +3635,23 @@ 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_cv_header_stdc=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_header_stdc=no
+ ac_cv_header_stdc=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <string.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "memchr" >/dev/null 2>&1; then
- :
+ $EGREP "memchr" >/dev/null 2>&1; then :
+
else
ac_cv_header_stdc=no
fi
@@ -2792,18 +3661,14 @@ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "free" >/dev/null 2>&1; then
- :
+ $EGREP "free" >/dev/null 2>&1; then :
+
else
ac_cv_header_stdc=no
fi
@@ -2813,16 +3678,13 @@ 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
+ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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))
@@ -2842,109 +3704,39 @@ main ()
for (i = 0; i < 256; i++)
if (XOR (islower (i), ISLOWER (i))
|| toupper (i) != TOUPPER (i))
- exit(2);
- exit (0);
+ return 2;
+ 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
- :
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+if ac_fn_c_try_run "$LINENO"; then :
-( exit $ac_status )
-ac_cv_header_stdc=no
+else
+ ac_cv_header_stdc=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
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
-echo "${ECHO_T}$ac_cv_header_stdc" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5
+$as_echo "$ac_cv_header_stdc" >&6; }
if test $ac_cv_header_stdc = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define STDC_HEADERS 1
-_ACEOF
+$as_echo "#define STDC_HEADERS 1" >>confdefs.h
fi
# On IRIX 5.3, sys/types and inttypes.h are conflicting.
-
-
-
-
-
-
-
-
-
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
-
-#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
-
-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
+do :
+ as_ac_Header=`$as_echo "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 `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF
fi
@@ -2953,17 +3745,13 @@ done
- 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking dirent.h" >&5
+$as_echo_n "checking dirent.h... " >&6; }
+if ${tcl_cv_dirent_h+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -2993,535 +3781,52 @@ 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
+ 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$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_dirent_h" >&5
-echo "${ECHO_T}$tcl_cv_dirent_h" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_dirent_h" >&5
+$as_echo "$tcl_cv_dirent_h" >&6; }
if test $tcl_cv_dirent_h = no; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_DIRENT_H 1
-_ACEOF
+$as_echo "#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_mongrel "$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
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*
-
- 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>
+ $EGREP "strtol" >/dev/null 2>&1; then :
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "strtoul" >/dev/null 2>&1; then
- :
else
tcl_ok=0
fi
rm -f 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
- :
+ $EGREP "strtoul" >/dev/null 2>&1; then :
+
else
tcl_ok=0
fi
@@ -3529,184 +3834,38 @@ rm -f conftest*
if test $tcl_ok = 0; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_STDLIB_H 1
-_ACEOF
+$as_echo "#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_mongrel "$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
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
- :
+ $EGREP "strstr" >/dev/null 2>&1; then :
+
else
tcl_ok=0
fi
rm -f 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
- :
+ $EGREP "strerror" >/dev/null 2>&1; then :
+
else
tcl_ok=0
fi
@@ -3718,454 +3877,38 @@ rm -f conftest*
if test $tcl_ok = 0; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_STRING_H 1
-_ACEOF
+$as_echo "#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
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/wait.h" "ac_cv_header_sys_wait_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_wait_h" = xyes; then :
-
- 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_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
+$as_echo "#define NO_SYS_WAIT_H 1" >>confdefs.h
-# 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
- 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_mongrel "$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
-cat >>confdefs.h <<\_ACEOF
-#define NO_DLFCN_H 1
-_ACEOF
+$as_echo "#define NO_DLFCN_H 1" >>confdefs.h
fi
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
-
-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
+ for ac_header in sys/param.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/param.h" "ac_cv_header_sys_param_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_param_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_SYS_PARAM_H 1
_ACEOF
fi
@@ -4186,18 +3929,14 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -pipe" >&5
+$as_echo_n "checking if the compiler understands -pipe... " >&6; }
+if ${tcl_cv_cc_pipe+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -4208,614 +3947,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_cc_pipe=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_pipe=no
+ 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.$ac_ext
CFLAGS=$hold_cflags
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cc_pipe" >&5
-echo "${ECHO_T}$tcl_cv_cc_pipe" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5
+$as_echo "$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
-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
-
- fi
-
- 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. */
-
-/* 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
-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
+# Check whether --with-encoding was given.
+if test "${with_encoding+set}" = set; then :
+ withval=$with_encoding; with_tcencoding=${withval}
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
-
- 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
-/* 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_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"
-
-
-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
-/* 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
-
- 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
@@ -4825,9 +3982,7 @@ _ACEOF
else
-cat >>confdefs.h <<\_ACEOF
-#define TCL_CFGVAL_ENCODING "iso8859-1"
-_ACEOF
+$as_echo "#define TCL_CFGVAL_ENCODING \"iso8859-1\"" >>confdefs.h
fi
@@ -4842,97 +3997,8 @@ _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
MATH_LIBS="-lm"
@@ -4944,211 +4010,45 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -linet" >&5
+$as_echo_n "checking for main in -linet... " >&6; }
+if ${ac_cv_lib_inet_main+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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 ();
+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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_main" >&5
+$as_echo "$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_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
+ ac_fn_c_check_header_mongrel "$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_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
+$as_echo "#define HAVE_NET_ERRNO_H 1" >>confdefs.h
fi
@@ -5173,530 +4073,400 @@ 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
+ ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect"
+if test "x$ac_cv_func_connect" = xyes; then :
+ tcl_checkSocket=0
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* 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. */
+ tcl_checkSocket=1
+fi
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+ 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 :
-#undef connect
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for setsockopt in -lsocket" >&5
+$as_echo_n "checking for setsockopt in -lsocket... " >&6; }
+if ${ac_cv_lib_socket_setsockopt+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lsocket $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 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
-}
+extern "C"
#endif
-
+char setsockopt ();
int
main ()
{
-return f != connect;
+return setsockopt ();
;
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
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_socket_setsockopt=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_connect=no
+ ac_cv_lib_socket_setsockopt=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core 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_func_connect" >&5
-echo "${ECHO_T}$ac_cv_func_connect" >&6
-if test $ac_cv_func_connect = yes; then
- tcl_checkSocket=0
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_setsockopt" >&5
+$as_echo "$ac_cv_lib_socket_setsockopt" >&6; }
+if test "x$ac_cv_lib_socket_setsockopt" = xyes; then :
+ LIBS="$LIBS -lsocket"
else
- tcl_checkSocket=1
+ tcl_checkBoth=1
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. */
+ 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
+ LIBS=$tk_oldLibs
+fi
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+ fi
+ ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname"
+if test "x$ac_cv_func_gethostbyname" = xyes; then :
-#undef setsockopt
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnsl" >&5
+$as_echo_n "checking for gethostbyname in -lnsl... " >&6; }
+if ${ac_cv_lib_nsl_gethostbyname+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lnsl $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
-/* Override any gcc2 internal prototype to avoid an error. */
+/* 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
-/* We use char because int might match the return type of a gcc2
+char gethostbyname ();
+int
+main ()
+{
+return gethostbyname ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_nsl_gethostbyname=yes
+else
+ ac_cv_lib_nsl_gethostbyname=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+LIBS=$ac_check_lib_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostbyname" >&5
+$as_echo "$ac_cv_lib_nsl_gethostbyname" >&6; }
+if test "x$ac_cv_lib_nsl_gethostbyname" = xyes; then :
+ LIBS="$LIBS -lnsl"
+fi
+
+fi
+
+
+
+$as_echo "#define _REENTRANT 1" >>confdefs.h
+
+
+$as_echo "#define _THREAD_SAFE 1" >>confdefs.h
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5
+$as_echo_n "checking for pthread_mutex_init in -lpthread... " >&6; }
+if ${ac_cv_lib_pthread_pthread_mutex_init+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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 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
-}
+extern "C"
#endif
-
+char pthread_mutex_init ();
int
main ()
{
-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
+if ac_fn_c_try_link "$LINENO"; 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_func_setsockopt=no
+ 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$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
- :
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
+$as_echo "$ac_cv_lib_pthread_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes; then :
+ tcl_ok=yes
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
+ 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]
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5
+$as_echo_n "checking for __pthread_mutex_init in -lpthread... " >&6; }
+if ${ac_cv_lib_pthread___pthread_mutex_init+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char setsockopt ();
+char __pthread_mutex_init ();
int
main ()
{
-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
+if ac_fn_c_try_link "$LINENO"; 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_socket_setsockopt=no
+ 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$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"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
+$as_echo "$ac_cv_lib_pthread___pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes; then :
+ tcl_ok=yes
else
- tcl_checkBoth=1
-fi
-
+ 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
+
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -lpthread"
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5
+$as_echo_n "checking for pthread_mutex_init in -lpthreads... " >&6; }
+if ${ac_cv_lib_pthreads_pthread_mutex_init+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ ac_check_lib_save_LIBS=$LIBS
+LIBS="-lpthreads $LIBS"
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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
-
-/* 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
-}
+extern "C"
#endif
-
+char pthread_mutex_init ();
int
main ()
{
-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
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_pthreads_pthread_mutex_init=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_func_accept=no
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
+$as_echo "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes; then :
+ _ok=yes
else
- LIBS=$tk_oldLibs
+ 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
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -lpthreads"
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5
+$as_echo_n "checking for pthread_mutex_init in -lc... " >&6; }
+if ${ac_cv_lib_c_pthread_mutex_init+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ 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
-}
+extern "C"
#endif
-
+char pthread_mutex_init ();
int
main ()
{
-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
+if ac_fn_c_try_link "$LINENO"; 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_func_gethostbyname=no
+ 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$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
- :
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5
+$as_echo "$ac_cv_lib_c_pthread_mutex_init" >&6; }
+if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes; then :
+ tcl_ok=yes
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
+ tcl_ok=no
+fi
+
+ if test "$tcl_ok" = "no"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5
+$as_echo_n "checking for pthread_mutex_init in -lc_r... " >&6; }
+if ${ac_cv_lib_c_r_pthread_mutex_init+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gethostbyname ();
+char pthread_mutex_init ();
int
main ()
{
-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
+if ac_fn_c_try_link "$LINENO"; 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_nsl_gethostbyname=no
+ 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$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"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
+$as_echo "$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
+ tcl_ok=no
fi
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -pthread"
+ else
+ { $as_echo "$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
+$as_echo "$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"
+ for ac_func in pthread_attr_setstacksize pthread_atfork
+do :
+ as_ac_var=`$as_echo "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 `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+done
+
+ LIBS=$ac_saved_libs
+
+ # TIP #509
+ ac_fn_c_check_decl "$LINENO" "PTHREAD_MUTEX_RECURSIVE" "ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" "#include <pthread.h>
+"
+if test "x$ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" = xyes; then :
+ ac_have_decl=1
+else
+ ac_have_decl=0
+fi
+
+cat >>confdefs.h <<_ACEOF
+#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE $ac_have_decl
+_ACEOF
+if test $ac_have_decl = 1; then :
+ tcl_ok=yes
+else
+ tcl_ok=no
fi
@@ -5705,15 +4475,15 @@ fi
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
+$as_echo_n "checking how to build libraries... " >&6; }
+ # Check whether --enable-shared was given.
+if test "${enable_shared+set}" = set; then :
+ enableval=$enable_shared; tcl_ok=$enableval
else
tcl_ok=yes
-fi;
+fi
+
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
@@ -5723,21 +4493,20 @@ fi;
fi
if test "$tcl_ok" = "yes" ; then
- echo "$as_me:$LINENO: result: shared" >&5
-echo "${ECHO_T}shared" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared" >&5
+$as_echo "shared" >&6; }
SHARED_BUILD=1
else
- echo "$as_me:$LINENO: result: static" >&5
-echo "${ECHO_T}static" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5
+$as_echo "static" >&6; }
SHARED_BUILD=0
-cat >>confdefs.h <<\_ACEOF
-#define STATIC_BUILD 1
-_ACEOF
+$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
+
#--------------------------------------------------------------------
# Look for a native installed tclsh binary (if available)
# If one cannot be found then use the binary we build (fails for
@@ -5745,10 +4514,10 @@ _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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
+$as_echo_n "checking for tclsh... " >&6; }
+ if ${ac_cv_path_tclsh+:} false; then :
+ $as_echo_n "(cached) " >&6
else
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
@@ -5769,13 +4538,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
+$as_echo "No tclsh found on PATH" >&6; }
fi
@@ -5788,364 +4557,191 @@ 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_mongrel "$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
+ 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
+ zlib_ok=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: 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
-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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5
+$as_echo_n "checking for library containing deflateSetHeader... " >&6; }
+if ${ac_cv_search_deflateSetHeader+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ 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. */
+#ifdef __cplusplus
+extern "C"
+#endif
+char deflateSetHeader ();
int
main ()
{
-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
-
-ac_cv_type_gz_header=no
+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 conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext
+ if ${ac_cv_search_deflateSetHeader+:} false; then :
+ break
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
- :
+done
+if ${ac_cv_search_deflateSetHeader+:} false; then :
+
else
- zlib_ok=no
+ ac_cv_search_deflateSetHeader=no
fi
+rm conftest.$ac_ext
+LIBS=$ac_func_search_save_LIBS
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5
+$as_echo "$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
- zlib_ok=no
+ zlib_ok=no
+
+fi
+
+fi
+if test $zlib_ok = no; then :
+
+ ZLIB_OBJS=\${ZLIB_OBJS}
+
+ ZLIB_SRCS=\${ZLIB_SRCS}
+
+ ZLIB_INCLUDE=-I\${ZLIB_DIR}
+
+
+fi
+
+$as_echo "#define HAVE_ZLIB 1" >>confdefs.h
+
+
+#------------------------------------------------------------------------
+# Add stuff for libtommath
+
+libtommath_ok=yes
+
+# Check whether --with-system-libtommath was given.
+if test "${with_system_libtommath+set}" = set; then :
+ withval=$with_system_libtommath; libtommath_ok=${withval}
fi
+if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
+ ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default"
+if test "x$ac_cv_header_tommath_h" = xyes; then :
-if test $zlib_ok = yes; 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 :
- 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. */
+ libtommath_ok=no
+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 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=no
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 $libtommath_ok = yes; then :
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5
+$as_echo_n "checking for mp_log_u32 in -ltommath... " >&6; }
+if ${ac_cv_lib_tommath_mp_log_u32+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char deflateSetHeader ();
+char mp_log_u32 ();
int
main ()
{
-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
+if ac_fn_c_try_link "$LINENO"; then :
+ ac_cv_lib_tommath_mp_log_u32=yes
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
+ ac_cv_lib_tommath_mp_log_u32=no
fi
-LIBS=$ac_func_search_save_LIBS
+rm -f core 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_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"
-
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5
+$as_echo "$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
- zlib_ok=no
-
+ libtommath_ok=no
fi
fi
+fi
+if test $libtommath_ok = yes; then :
-if test $zlib_ok = no; then
- ZLIB_OBJS=\${ZLIB_OBJS}
+$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
- ZLIB_SRCS=\${ZLIB_SRCS}
- ZLIB_INCLUDE=-I\${ZLIB_DIR}
+else
+ 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
@@ -6156,10 +4752,10 @@ _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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_RANLIB+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
@@ -6169,35 +4765,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
+$as_echo "$RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_RANLIB+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_RANLIB"; then
ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
@@ -6207,28 +4805,38 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
+$as_echo "$ac_ct_RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
@@ -6237,52 +4845,47 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
+$as_echo_n "checking if 64bit support is requested... " >&6; }
+ # Check whether --enable-64bit was given.
+if test "${enable_64bit+set}" = set; then :
+ enableval=$enable_64bit; do64bit=$enableval
else
do64bit=no
-fi;
- echo "$as_me:$LINENO: result: $do64bit" >&5
-echo "${ECHO_T}$do64bit" >&6
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit Sparc VIS support is requested" >&5
+$as_echo_n "checking if 64bit Sparc VIS support is requested... " >&6; }
+ # Check whether --enable-64bit-vis was given.
+if test "${enable_64bit_vis+set}" = set; then :
+ enableval=$enable_64bit_vis; do64bitVIS=$enableval
else
do64bitVIS=no
-fi;
- echo "$as_me:$LINENO: result: $do64bitVIS" >&5
-echo "${ECHO_T}$do64bitVIS" >&6
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bitVIS" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler supports visibility \"hidden\"" >&5
+$as_echo_n "checking if compiler supports visibility \"hidden\"... " >&6; }
+if ${tcl_cv_cc_visibility_hidden+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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);
@@ -6295,96 +4898,61 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_visibility_hidden" >&5
+$as_echo "$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
+$as_echo "#define MODULE_SCOPE extern __attribute__((__visibility__(\"hidden\")))" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_HIDDEN 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if rpath support is requested" >&5
+$as_echo_n "checking if rpath support is requested... " >&6; }
+ # Check whether --enable-rpath was given.
+if test "${enable_rpath+set}" = set; then :
+ enableval=$enable_rpath; doRpath=$enableval
else
doRpath=yes
-fi;
- echo "$as_me:$LINENO: result: $doRpath" >&5
-echo "${ECHO_T}$doRpath" >&6
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking system version" >&5
+$as_echo_n "checking system version... " >&6; }
+if ${tcl_cv_sys_version+:} false; then :
+ $as_echo_n "(cached) " >&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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
+$as_echo "$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
@@ -6395,79 +4963,51 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
+$as_echo_n "checking for dlopen in -ldl... " >&6; }
+if ${ac_cv_lib_dl_dlopen+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char dlopen ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5
+$as_echo "$ac_cv_lib_dl_dlopen" >&6; }
+if test "x$ac_cv_lib_dl_dlopen" = xyes; then :
have_dl=yes
else
have_dl=no
@@ -6493,10 +5033,18 @@ 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 -Wwrite-strings -Wpointer-arith"
+ case "${CC}" in
+ *++|*++-*)
+ ;;
+ *)
+ CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
+ ;;
+ esac
+
else
@@ -6504,14 +5052,13 @@ else
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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_AR+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
@@ -6521,35 +5068,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
+$as_echo "$AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_AR+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_AR"; then
ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
@@ -6559,27 +5108,38 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
+$as_echo "$ac_ct_AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
@@ -6589,15 +5149,12 @@ 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
@@ -6609,11 +5166,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5
+$as_echo "Using $CC for compiling with threads" >&6; }
fi
-
LIBS="$LIBS -lc"
SHLIB_CFLAGS=""
SHLIB_SUFFIX=".so"
@@ -6626,12 +5182,12 @@ 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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
+$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
else
@@ -6644,17 +5200,15 @@ 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}'
@@ -6663,12 +5217,11 @@ else
CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
fi
-
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
else
- if test "$GCC" = yes; then
+ if test "$GCC" = yes; then :
SHLIB_LD='${CC} -shared -Wl,-bexpall'
@@ -6678,14 +5231,12 @@ else
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"
@@ -6699,71 +5250,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lbind" >&5
+$as_echo_n "checking for inet_ntoa in -lbind... " >&6; }
+if ${ac_cv_lib_bind_inet_ntoa+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char inet_ntoa ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bind_inet_ntoa" >&5
+$as_echo "$ac_cv_lib_bind_inet_ntoa" >&6; }
+if test "x$ac_cv_lib_bind_inet_ntoa" = xyes; then :
LIBS="$LIBS -lbind -lsocket"
fi
@@ -6787,8 +5310,8 @@ fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
- CYGWIN_*|MINGW32*)
- SHLIB_CFLAGS=""
+ CYGWIN_*)
+ SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
@@ -6800,16 +5323,12 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5
+$as_echo_n "checking for Cygwin version of gcc... " >&6; }
+if ${ac_cv_cygwin+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#ifdef __CYGWIN__
@@ -6824,49 +5343,18 @@ 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_cv_cygwin=no
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_cygwin=yes
+ ac_cv_cygwin=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
-echo "${ECHO_T}$ac_cv_cygwin" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5
+$as_echo "$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
@@ -6896,71 +5384,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5
+$as_echo_n "checking for inet_ntoa in -lnetwork... " >&6; }
+if ${ac_cv_lib_network_inet_ntoa+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char inet_ntoa ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_inet_ntoa" >&5
+$as_echo "$ac_cv_lib_network_inet_ntoa" >&6; }
+if test "x$ac_cv_lib_network_inet_ntoa" = xyes; then :
LIBS="$LIBS -lnetwork"
fi
@@ -6968,18 +5428,14 @@ fi
HP-UX-*.11.*)
# Use updated header definitions where possible
-cat >>confdefs.h <<\_ACEOF
-#define _XOPEN_SOURCE_EXTENDED 1
-_ACEOF
+$as_echo "#define _XOPEN_SOURCE_EXTENDED 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define _XOPEN_SOURCE 1
-_ACEOF
+$as_echo "#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"
@@ -6988,78 +5444,49 @@ else
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
+$as_echo_n "checking for shl_load in -ldld... " >&6; }
+if ${ac_cv_lib_dld_shl_load+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char shl_load ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
+$as_echo "$ac_cv_lib_dld_shl_load" >&6; }
+if test "x$ac_cv_lib_dld_shl_load" = xyes; then :
tcl_ok=yes
else
tcl_ok=no
fi
- if test "$tcl_ok" = yes; then
+ if test "$tcl_ok" = yes; then :
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
@@ -7071,8 +5498,7 @@ 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}
@@ -7083,30 +5509,28 @@ else
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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
+$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
;;
esac
@@ -7118,82 +5542,52 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
+$as_echo_n "checking for shl_load in -ldld... " >&6; }
+if ${ac_cv_lib_dld_shl_load+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char shl_load ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
+$as_echo "$ac_cv_lib_dld_shl_load" >&6; }
+if test "x$ac_cv_lib_dld_shl_load" = xyes; then :
tcl_ok=yes
else
tcl_ok=no
fi
- if test "$tcl_ok" = yes; then
+ if test "$tcl_ok" = yes; then :
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
@@ -7205,28 +5599,24 @@ 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=""
@@ -7234,21 +5624,18 @@ 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"
@@ -7267,7 +5654,6 @@ else
LDFLAGS="$LDFLAGS -n32"
fi
-
;;
IRIX64-6.*)
SHLIB_CFLAGS=""
@@ -7275,29 +5661,26 @@ 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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5
+$as_echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;}
else
@@ -7308,12 +5691,10 @@ else
fi
-
fi
-
;;
Linux*|GNU*|NetBSD-Debian)
- SHLIB_CFLAGS="-fPIC"
+ SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
@@ -7326,31 +5707,25 @@ fi
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--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 "`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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -m64 flag" >&5
+$as_echo_n "checking if compiler accepts -m64 flag... " >&6; }
+if ${tcl_cv_cc_m64+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7361,62 +5736,35 @@ 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_cc_m64=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_m64=no
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_m64" >&5
+$as_echo "$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"
@@ -7426,33 +5774,11 @@ 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`
@@ -7468,24 +5794,18 @@ 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
@@ -7498,44 +5818,32 @@ 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"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
- SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@"
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='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
-
- 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
-
+ # The -pthread needs to go in the LDFLAGS, not LIBS
+ LIBS=`echo $LIBS | sed s/-pthread//`
+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
+ LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
@@ -7558,23 +5866,19 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch ppc64 flag" >&5
+$as_echo_n "checking if compiler accepts -arch ppc64 flag... " >&6; }
+if ${tcl_cv_cc_arch_ppc64+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7585,62 +5889,33 @@ 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_cc_arch_ppc64=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cc_arch_ppc64=no
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_ppc64" >&5
+$as_echo "$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)
- 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch x86_64 flag" >&5
+$as_echo_n "checking if compiler accepts -arch x86_64 flag... " >&6; }
+if ${tcl_cv_cc_arch_x86_64+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7651,79 +5926,48 @@ 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_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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_x86_64" >&5
+$as_echo "$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;;
*)
- { 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;};;
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5
+$as_echo "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};;
esac
else
# Check for combined 32-bit and 64-bit fat build
if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \
- && 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if ld accepts -single_module flag" >&5
+$as_echo_n "checking if ld accepts -single_module flag... " >&6; }
+if ${tcl_cv_ld_single_module+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7734,64 +5978,35 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_single_module" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5
+$as_echo_n "checking if ld accepts -search_paths_first flag... " >&6; }
+if ${tcl_cv_ld_search_paths_first+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7802,89 +6017,59 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_search_paths_first" >&5
+$as_echo "$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
+$as_echo "#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_LIBRARY_PATH"
-cat >>confdefs.h <<\_ACEOF
-#define MAC_OSX_TCL 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use CoreFoundation" >&5
+$as_echo_n "checking whether to use CoreFoundation... " >&6; }
+ # Check whether --enable-corefoundation was given.
+if test "${enable_corefoundation+set}" = set; then :
+ enableval=$enable_corefoundation; tcl_corefoundation=$enableval
else
tcl_corefoundation=yes
-fi;
- echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5
-echo "${ECHO_T}$tcl_corefoundation" >&6
- if test $tcl_corefoundation = yes; then
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_corefoundation" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for CoreFoundation.framework" >&5
+$as_echo_n "checking for CoreFoundation.framework... " >&6; }
+if ${tcl_cv_lib_corefoundation+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7894,13 +6079,8 @@ 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
@@ -7911,77 +6091,45 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation" >&5
+$as_echo "$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
+$as_echo "#define HAVE_COREFOUNDATION 1" >>confdefs.h
else
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for 64-bit CoreFoundation" >&5
+$as_echo_n "checking for 64-bit CoreFoundation... " >&6; }
+if ${tcl_cv_lib_corefoundation_64+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -7992,114 +6140,43 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation_64" >&5
+$as_echo "$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
+$as_echo "#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
-
- ;;
- 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"
+$as_echo "#define _OE_SOCKETS 1" >>confdefs.h
-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='ld -shared -expect_unresolved "*"'
@@ -8108,48 +6185,38 @@ else
SHLIB_LD='ld -non_shared -expect_unresolved "*"'
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
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
-
+ 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"
@@ -8163,18 +6230,17 @@ 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"
+ SHLIB_CFLAGS="-fPIC -melf"
+ LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
else
- SHLIB_CFLAGS="-Kpic -belf"
- LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
+ SHLIB_CFLAGS="-Kpic -belf"
+ LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
fi
-
SHLIB_LD="ld -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
@@ -8183,35 +6249,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
@@ -8219,21 +6256,17 @@ fi
# won't define thread-safe library routines.
-cat >>confdefs.h <<\_ACEOF
-#define _REENTRANT 1
-_ACEOF
+$as_echo "#define _REENTRANT 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define _POSIX_PTHREAD_SEMANTICS 1
-_ACEOF
+$as_echo "#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}'
@@ -8246,37 +6279,32 @@ else
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
+$as_echo "#define _REENTRANT 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define _POSIX_PTHREAD_SEMANTICS 1
-_ACEOF
+$as_echo "#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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5
+$as_echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;}
else
@@ -8287,11 +6315,10 @@ else
fi
-
else
do64bit_ok=yes
- if test "$do64bitVIS" = yes; then
+ if test "$do64bitVIS" = yes; then :
CFLAGS="$CFLAGS -xarch=v9a"
LDFLAGS_ARCH="-xarch=v9a"
@@ -8302,17 +6329,15 @@ else
LDFLAGS_ARCH="-xarch=v9"
fi
-
# Solaris 64 uses this as well
#LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64"
fi
-
else
- if test "$arch" = "amd64 i386"; then
+ 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]*)
@@ -8320,8 +6345,8 @@ 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;};;
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
+$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};;
esac
else
@@ -8338,169 +6363,32 @@ 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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported for $arch" >&5
+$as_echo "$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
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use -lsunmath for fp rounding control" >&5
+$as_echo_n "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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "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
-
-# 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
+ ac_fn_c_check_header_mongrel "$LINENO" "sunmath.h" "ac_cv_header_sunmath_h" "$ac_includes_default"
+if test "x$ac_cv_header_sunmath_h" = xyes; then :
fi
@@ -8509,26 +6397,24 @@ fi
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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.
@@ -8539,26 +6425,22 @@ fi
#CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
else
- if test "$arch" = "amd64 i386"; then
+ if test "$arch" = "amd64 i386"; then :
SHLIB_LD="$SHLIB_LD -m64 -static-libgcc"
fi
-
fi
-
fi
-
else
- if test "$use_sunmath" = yes; then
+ if test "$use_sunmath" = yes; then :
textmode=textoff
else
textmode=text
fi
-
case $system in
SunOS-5.[1-9][0-9]*|SunOS-5.[7-9])
SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";;
@@ -8569,7 +6451,6 @@ fi
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
fi
-
;;
UNIX_SV* | UnixWare-5*)
SHLIB_CFLAGS="-KPIC"
@@ -8580,19 +6461,15 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ld accepts -Bexport flag" >&5
+$as_echo_n "checking for ld accepts -Bexport flag... " >&6; }
+if ${tcl_cv_ld_Bexport+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
@@ -8603,93 +6480,63 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5
+$as_echo "$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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5
+$as_echo "$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
+$as_echo "#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
+ # Check whether --enable-load was given.
+if test "${enable_load+set}" = set; then :
+ enableval=$enable_load; tcl_ok=$enableval
else
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
- { 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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5
+$as_echo "$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=""
@@ -8701,56 +6548,52 @@ 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-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
- IRIX*) ;;
- NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;;
+ HP_UX*) ;;
Darwin-*) ;;
+ IRIX*) ;;
+ Linux*|GNU*) ;;
+ NetBSD-*|OpenBSD-*) ;;
+ OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
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
+$as_echo "#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)"
@@ -8761,12 +6604,11 @@ else
fi
-
else
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
- if test "$RANLIB" = ""; then
+ if test "$RANLIB" = ""; then :
MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
@@ -8775,14 +6617,12 @@ else
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}'
@@ -8791,33 +6631,27 @@ else
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
+$as_echo_n "checking for cast to union support... " >&6; }
+if ${tcl_cv_cast_to_union+:} false; then :
+ $as_echo_n "(cached) " >&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. */
int
@@ -8831,48 +6665,31 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
-echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
+$as_echo "$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
+$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
+ ac_fn_c_check_header_mongrel "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
+if test "x$ac_cv_header_stdbool_h" = xyes; then :
+
+$as_echo "#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
# would use TCL_DL_LIBS instead of TCL_LIBS.
@@ -8915,37 +6732,33 @@ _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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
+$as_echo_n "checking for build with symbols... " >&6; }
+ # Check whether --enable-symbols was given.
+if test "${enable_symbols+set}" = set; then :
+ enableval=$enable_symbols; tcl_ok=$enableval
else
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
+$as_echo "#define NDEBUG 1" >>confdefs.h
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
-cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_OPTIMIZED 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
+$as_echo "yes (standard debugging)" >&6; }
fi
fi
@@ -8953,45 +6766,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
+$as_echo "#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
+$as_echo "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define TCL_COMPILE_STATS 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
+$as_echo "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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
+$as_echo "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
+$as_echo "#define MP_PREC 4" >>confdefs.h
#--------------------------------------------------------------------
@@ -8999,18 +6799,14 @@ _ACEOF
#--------------------------------------------------------------------
- echo "$as_me:$LINENO: checking for required early compiler flags" >&5
-echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for required early compiler flags" >&5
+$as_echo_n "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
+ if ${tcl_cv_flag__isoc99_source+:} false; then :
+ $as_echo_n "(cached) " >&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 <stdlib.h>
int
@@ -9021,38 +6817,10 @@ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _ISOC99_SOURCE 1
#include <stdlib.h>
@@ -9064,58 +6832,28 @@ 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
+ 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.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define _ISOC99_SOURCE 1
-_ACEOF
+$as_echo "#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
+ if ${tcl_cv_flag__largefile64_source+:} false; then :
+ $as_echo_n "(cached) " >&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/stat.h>
int
@@ -9126,38 +6864,10 @@ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
@@ -9169,58 +6879,28 @@ 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
+ 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.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define _LARGEFILE64_SOURCE 1
-_ACEOF
+$as_echo "#define _LARGEFILE64_SOURCE 1" >>confdefs.h
tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
fi
- if test "${tcl_cv_flag__largefile_source64+set}" = set; then
- echo $ECHO_N "(cached) $ECHO_C" >&6
+ if ${tcl_cv_flag__largefile_source64+:} false; then :
+ $as_echo_n "(cached) " >&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/stat.h>
int
@@ -9231,38 +6911,10 @@ char *p = (char *)open64;
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__largefile_source64=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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _LARGEFILE_SOURCE64 1
#include <sys/stat.h>
@@ -9274,72 +6926,42 @@ char *p = (char *)open64;
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__largefile_source64=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_flag__largefile_source64=no
+ tcl_cv_flag__largefile_source64=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define _LARGEFILE_SOURCE64 1
-_ACEOF
+$as_echo "#define _LARGEFILE_SOURCE64 1" >>confdefs.h
tcl_flags="$tcl_flags _LARGEFILE_SOURCE64"
fi
if test "x${tcl_flags}" = "x" ; then
- echo "$as_me:$LINENO: result: none" >&5
-echo "${ECHO_T}none" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5
+$as_echo "none" >&6; }
else
- echo "$as_me:$LINENO: result: ${tcl_flags}" >&5
-echo "${ECHO_T}${tcl_flags}" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${tcl_flags}" >&5
+$as_echo "${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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for 64-bit integer type" >&5
+$as_echo_n "checking for 64-bit integer type... " >&6; }
+ if ${tcl_cv_type_64bit+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
@@ -9350,44 +6972,16 @@ __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
+if ac_fn_c_try_compile "$LINENO"; then :
tcl_type_64bit=__int64
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_type_64bit="long long"
+ 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
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ # 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
@@ -9400,66 +6994,35 @@ switch (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 :
tcl_cv_type_64bit=${tcl_type_64bit}
-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
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
if test "${tcl_cv_type_64bit}" = none ; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_WIDE_INT_IS_LONG 1
-_ACEOF
+$as_echo "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h
- echo "$as_me:$LINENO: result: using long" >&5
-echo "${ECHO_T}using long" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${tcl_cv_type_64bit}" >&5
+$as_echo "${tcl_cv_type_64bit}" >&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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5
+$as_echo_n "checking for struct dirent64... " >&6; }
+if ${tcl_cv_struct_dirent64+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -9471,58 +7034,28 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_struct_dirent64" >&5
-echo "${ECHO_T}$tcl_cv_struct_dirent64" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5
+$as_echo "$tcl_cv_struct_dirent64" >&6; }
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_STRUCT_DIRENT64 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5
+$as_echo_n "checking for DIR64... " >&6; }
+if ${tcl_cv_DIR64+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -9535,58 +7068,28 @@ 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
+ tcl_cv_DIR64=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_DIR64" >&5
-echo "${ECHO_T}$tcl_cv_DIR64" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5
+$as_echo "$tcl_cv_DIR64" >&6; }
if test "x${tcl_cv_DIR64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_DIR64 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5
+$as_echo_n "checking for struct stat64... " >&6; }
+if ${tcl_cv_struct_stat64+:} false; then :
+ $as_echo_n "(cached) " >&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/stat.h>
int
@@ -9598,161 +7101,40 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_struct_stat64" >&5
-echo "${ECHO_T}$tcl_cv_struct_stat64" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_stat64" >&5
+$as_echo "$tcl_cv_struct_stat64" >&6; }
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_STRUCT_STAT64 1
-_ACEOF
+$as_echo "#define HAVE_STRUCT_STAT64 1" >>confdefs.h
fi
-
-
-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
+ for ac_func in open64 lseek64
+do :
+ as_ac_var=`$as_echo "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 `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for off64_t" >&5
+$as_echo_n "checking for off64_t... " >&6; }
+ if ${tcl_cv_type_off64_t+:} false; then :
+ $as_echo_n "(cached) " >&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>
int
@@ -9764,51 +7146,25 @@ 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
+ 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.$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
+$as_echo "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
fi
fi
@@ -9818,235 +7174,229 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5
+$as_echo_n "checking whether byte ordering is bigendian... " >&6; }
+if ${ac_cv_c_bigendian+:} false; then :
+ $as_echo_n "(cached) " >&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
+ 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.$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 ()
{
-#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 ()
{
#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
+ 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
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext 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. */
+#include <limits.h>
-# 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. */
+int
+main ()
+{
+#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN)
+ bogus endian macros
+ #endif
+
+ ;
+ return 0;
+}
_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. */
-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 ()
{
- _ascii (); _ebcdic ();
+#ifndef _BIG_ENDIAN
+ 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 grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then
+if ac_fn_c_try_compile "$LINENO"; then :
ac_cv_c_bigendian=yes
+else
+ ac_cv_c_bigendian=no
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
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+rm -f core conftest.err conftest.$ac_objext 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. */
+short int ascii_mm[] =
+ { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
+ short int ascii_ii[] =
+ { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };
+ int use_ascii (int i) {
+ return ascii_mm[i] + ascii_ii[i];
+ }
+ short int ebcdic_ii[] =
+ { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 };
+ 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 ()
+{
+return use_ascii (foo) == use_ebcdic (foo);
+ ;
+ return 0;
+}
+_ACEOF
+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
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
+$ac_includes_default
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);
+
+ /* 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_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_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
+ ac_cv_c_bigendian=yes
fi
+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
+ conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+ fi
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)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5
+$as_echo "$ac_cv_c_bigendian" >&6; }
+ case $ac_cv_c_bigendian in #(
+ yes)
+ $as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h
+;; #(
+ no)
+ ;; #(
+ universal)
-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
+$as_echo "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h
+
+ ;; #(
+ *)
+ as_fn_error $? "unknown endianness
+ presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;;
+ esac
#--------------------------------------------------------------------
@@ -10055,110 +7405,17 @@ esac
#--------------------------------------------------------------------
# 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
-/* 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
+do :
+ ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd"
+if test "x$ac_cv_func_getcwd" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+#define HAVE_GETCWD 1
_ACEOF
else
-cat >>confdefs.h <<\_ACEOF
-#define USEGETWD 1
-_ACEOF
+$as_echo "#define USEGETWD 1" >>confdefs.h
fi
done
@@ -10166,731 +7423,121 @@ 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 ?
+ac_fn_c_check_func "$LINENO" "mkstemp" "ac_cv_func_mkstemp"
+if test "x$ac_cv_func_mkstemp" = xyes; then :
+ $as_echo "#define HAVE_MKSTEMP 1" >>confdefs.h
-
-
-
-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
-/* 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
+ case " $LIBOBJS " in
+ *" mkstemp.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
+ ;;
+esac
-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" "opendir" "ac_cv_func_opendir"
+if test "x$ac_cv_func_opendir" = xyes; then :
+ $as_echo "#define HAVE_OPENDIR 1" >>confdefs.h
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" ;;
+ case " $LIBOBJS " in
+ *" opendir.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS opendir.$ac_objext"
+ ;;
esac
fi
-done
+ac_fn_c_check_func "$LINENO" "strtol" "ac_cv_func_strtol"
+if test "x$ac_cv_func_strtol" = xyes; then :
+ $as_echo "#define HAVE_STRTOL 1" >>confdefs.h
-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
-/* 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. */
+ case " $LIBOBJS " in
+ *" strtol.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS strtol.$ac_objext"
+ ;;
+esac
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+fi
-#undef strerror
+ac_fn_c_check_func "$LINENO" "waitpid" "ac_cv_func_waitpid"
+if test "x$ac_cv_func_waitpid" = xyes; then :
+ $as_echo "#define HAVE_WAITPID 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 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
-
-int
-main ()
-{
-return f != strerror;
- ;
- 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
+ case " $LIBOBJS " in
+ *" waitpid.$ac_objext "* ) ;;
+ *) LIBOBJS="$LIBOBJS waitpid.$ac_objext"
+ ;;
+esac
-ac_cv_func_strerror=no
-fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext 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
+ac_fn_c_check_func "$LINENO" "strerror" "ac_cv_func_strerror"
+if test "x$ac_cv_func_strerror" = xyes; then :
-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
-
-/* 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. */
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
+$as_echo "#define NO_STRERROR 1" >>confdefs.h
-#undef getwd
-
-/* 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
-
-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
-
-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
-cat >>confdefs.h <<\_ACEOF
-#define NO_GETWD 1
-_ACEOF
-
-fi
+ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd"
+if test "x$ac_cv_func_getwd" = xyes; then :
-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. */
+$as_echo "#define NO_GETWD 1" >>confdefs.h
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef wait3
-
-/* 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
-
-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
-
-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
-cat >>confdefs.h <<\_ACEOF
-#define NO_WAIT3 1
-_ACEOF
-
-fi
+ac_fn_c_check_func "$LINENO" "wait3" "ac_cv_func_wait3"
+if test "x$ac_cv_func_wait3" = xyes; then :
-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. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-#undef uname
+$as_echo "#define NO_WAIT3 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
-cat >>confdefs.h <<\_ACEOF
-#define NO_UNAME 1
-_ACEOF
+$as_echo "#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
-
-#undef realpath
-
-/* 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_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath"
+if test "x$ac_cv_func_realpath" = xyes; then :
-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
+$as_echo "#define NO_REALPATH 1" >>confdefs.h
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=`$as_echo "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 `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
else
@@ -10898,69 +7545,14 @@ else
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. */
-
+ 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>
-
-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
+"
+if test "x$ac_cv_type_struct_addrinfo" = xyes; then :
cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_ADDRINFO 1
@@ -10970,69 +7562,14 @@ _ACEOF
else
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>
-
-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
+"
+if test "x$ac_cv_type_struct_in6_addr" = xyes; then :
cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_IN6_ADDR 1
@@ -11042,69 +7579,14 @@ _ACEOF
else
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>
-
-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
+"
+if test "x$ac_cv_type_struct_sockaddr_in6" = xyes; then :
cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_SOCKADDR_IN6 1
@@ -11114,69 +7596,14 @@ _ACEOF
else
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>
-
-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
+"
+if test "x$ac_cv_type_struct_sockaddr_storage" = xyes; then :
cat >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_SOCKADDR_STORAGE 1
@@ -11189,108 +7616,18 @@ fi
if test "x$NEED_FAKE_RFC2553" = "x1"; then
-cat >>confdefs.h <<\_ACEOF
-#define NEED_FAKE_RFC2553 1
-_ACEOF
+$as_echo "#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
@@ -11299,110 +7636,16 @@ 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
-
-/* 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
-
-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
+ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r"
+if test "x$ac_cv_func_getpwuid_r" = xyes; 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 5 args" >&5
+$as_echo_n "checking for getpwuid_r with 5 args... " >&6; }
+if ${tcl_cv_api_getpwuid_r_5+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -11423,58 +7666,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_5" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 4 args" >&5
+$as_echo_n "checking for getpwuid_r with 4 args... " >&6; }
+if ${tcl_cv_api_getpwuid_r_4+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -11495,161 +7708,40 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_4" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#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_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
+ac_fn_c_check_func "$LINENO" "getpwnam_r" "ac_cv_func_getpwnam_r"
+if test "x$ac_cv_func_getpwnam_r" = xyes; then :
- 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 5 args" >&5
+$as_echo_n "checking for getpwnam_r with 5 args... " >&6; }
+if ${tcl_cv_api_getpwnam_r_5+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -11670,58 +7762,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_5" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 4 args" >&5
+$as_echo_n "checking for getpwnam_r with 4 args... " >&6; }
+if ${tcl_cv_api_getpwnam_r_4+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -11742,161 +7804,40 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_4" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 5 args" >&5
+$as_echo_n "checking for getgrgid_r with 5 args... " >&6; }
+if ${tcl_cv_api_getgrgid_r_5+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -11917,58 +7858,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_5" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 4 args" >&5
+$as_echo_n "checking for getgrgid_r with 4 args... " >&6; }
+if ${tcl_cv_api_getgrgid_r_4+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -11989,161 +7900,40 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_4" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#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
-
-/* 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
-
-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_fn_c_check_func "$LINENO" "getgrnam_r" "ac_cv_func_getgrnam_r"
+if test "x$ac_cv_func_getgrnam_r" = xyes; then :
-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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 5 args" >&5
+$as_echo_n "checking for getgrnam_r with 5 args... " >&6; }
+if ${tcl_cv_api_getgrnam_r_5+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -12164,58 +7954,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_5" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 4 args" >&5
+$as_echo_n "checking for getgrnam_r with 4 args... " >&6; }
+if ${tcl_cv_api_getgrnam_r_4+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -12236,273 +7996,88 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_4" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#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
+$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_MTSAFE_GETHOSTBYADDR 1
-_ACEOF
-
+$as_echo "#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
+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.
+$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_MTSAFE_GETHOSTBYADDR 1
-_ACEOF
+$as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 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>
-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
+ # Avoids picking hidden internal symbol from libc
+ ac_fn_c_check_decl "$LINENO" "gethostbyname_r" "ac_cv_have_decl_gethostbyname_r" "#include <netdb.h>
+"
+if test "x$ac_cv_have_decl_gethostbyname_r" = xyes; then :
+ ac_have_decl=1
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
+ ac_have_decl=0
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
+#define HAVE_DECL_GETHOSTBYNAME_R $ac_have_decl
_ACEOF
-
+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
+ 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
-
-/* 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. */
-
-#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
+ ac_fn_c_check_func "$LINENO" "gethostbyname_r" "ac_cv_func_gethostbyname_r"
+if test "x$ac_cv_func_gethostbyname_r" = xyes; 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 6 args" >&5
+$as_echo_n "checking for gethostbyname_r with 6 args... " >&6; }
+if ${tcl_cv_api_gethostbyname_r_6+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -12523,58 +8098,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_6" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 5 args" >&5
+$as_echo_n "checking for gethostbyname_r with 5 args... " >&6; }
+if ${tcl_cv_api_gethostbyname_r_5+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -12595,58 +8140,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_5" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 3 args" >&5
+$as_echo_n "checking for gethostbyname_r with 3 args... " >&6; }
+if ${tcl_cv_api_gethostbyname_r_3+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -12665,54 +8180,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_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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_3" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
@@ -12722,186 +8209,37 @@ 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
+ ac_fn_c_check_decl "$LINENO" "gethostbyaddr_r" "ac_cv_have_decl_gethostbyaddr_r" "#include <netdb.h>
+"
+if test "x$ac_cv_have_decl_gethostbyaddr_r" = xyes; then :
+ ac_have_decl=1
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
+ ac_have_decl=0
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
+#define HAVE_DECL_GETHOSTBYADDR_R $ac_have_decl
_ACEOF
-
+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
+ 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. */
-
-#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_fn_c_check_func "$LINENO" "gethostbyaddr_r" "ac_cv_func_gethostbyaddr_r"
+if test "x$ac_cv_func_gethostbyaddr_r" = xyes; then :
-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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 7 args" >&5
+$as_echo_n "checking for gethostbyaddr_r with 7 args... " >&6; }
+if ${tcl_cv_api_gethostbyaddr_r_7+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -12925,58 +8263,28 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_7" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 8 args" >&5
+$as_echo_n "checking for gethostbyaddr_r with 8 args... " >&6; }
+if ${tcl_cv_api_gethostbyaddr_r_8+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -13000,53 +8308,25 @@ 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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_8" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
@@ -13054,7 +8334,6 @@ fi
fi
- fi
fi
#---------------------------------------------------------------------------
@@ -13066,450 +8345,36 @@ fi
# sys/modem.h is needed on HP-UX.
#---------------------------------------------------------------------------
-
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
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "termios.h" "ac_cv_header_termios_h" "$ac_includes_default"
+if test "x$ac_cv_header_termios_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_TERMIOS_H 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
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_ioctl_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_SYS_IOCTL_H 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
-
-# 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
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/modem.h" "ac_cv_header_sys_modem_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_modem_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_SYS_MODEM_H 1
_ACEOF
fi
@@ -13527,17 +8392,13 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fd_set in sys/types" >&5
+$as_echo_n "checking for fd_set in sys/types... " >&6; }
+if ${tcl_cv_type_fd_set+:} false; then :
+ $as_echo_n "(cached) " >&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>
int
@@ -13548,58 +8409,30 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5
-echo "${ECHO_T}$tcl_cv_type_fd_set" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_fd_set" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for fd_mask in sys/select" >&5
+$as_echo_n "checking for fd_mask in sys/select... " >&6; }
+if ${tcl_cv_grep_fd_mask+:} false; then :
+ $as_echo_n "(cached) " >&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/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
tcl_cv_grep_fd_mask=missing
@@ -13607,190 +8440,118 @@ fi
rm -f conftest*
fi
-echo "$as_me:$LINENO: result: $tcl_cv_grep_fd_mask" >&5
-echo "${ECHO_T}$tcl_cv_grep_fd_mask" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_fd_mask" >&5
+$as_echo "$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
+$as_echo "#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
+$as_echo "#define NO_FD_SET 1" >>confdefs.h
fi
-#------------------------------------------------------------------------------
-# Find out all about time handling differences.
-#------------------------------------------------------------------------------
+#------------------------------------------------------------------------
+# Options for the notifier. Checks for epoll(7) on Linux, and
+# kqueue(2) on {DragonFly,Free,Net,Open}BSD
+#------------------------------------------------------------------------
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for advanced notifier support" >&5
+$as_echo_n "checking for advanced notifier support... " >&6; }
+case x`uname -s` in
+ xLinux)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: epoll(7)" >&5
+$as_echo "epoll(7)" >&6; }
+ for ac_header in sys/epoll.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/epoll.h" "ac_cv_header_sys_epoll_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_epoll_h" = xyes; then :
+ cat >>confdefs.h <<_ACEOF
+#define HAVE_SYS_EPOLL_H 1
+_ACEOF
+$as_echo "#define NOTIFIER_EPOLL 1" >>confdefs.h
-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
-/* end confdefs.h. */
-$ac_includes_default
-#include <$ac_header>
+
+done
+
+ for ac_header in sys/eventfd.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_eventfd_h" = xyes; then :
+ cat >>confdefs.h <<_ACEOF
+#define HAVE_SYS_EVENTFD_H 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_header_compiler=yes
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-ac_header_compiler=no
+$as_echo "#define HAVE_EVENTFD 1" >>confdefs.h
+
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>
+done
+;;
+ xDragonFlyBSD|xFreeBSD|xNetBSD|xOpenBSD)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: kqueue(2)" >&5
+$as_echo "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=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh`
+ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default"
+if eval test \"x\$"$as_ac_Header"\" = x"yes"; then :
+ cat >>confdefs.h <<_ACEOF
+#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1
_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
+ tcl_kqueue_headers=${tcl_kqueue_headers}y
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
+done
-# 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
- ;;
+ if test $tcl_kqueue_headers = xyyy; then :
+
+
+$as_echo "#define NOTIFIER_KQUEUE 1" >>confdefs.h
+
+fi;;
+ xDarwin)
+ # Assume that we've got CoreFoundation present (checked elsewhere because
+ # of wider impact).
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: OSX" >&5
+$as_echo "OSX" >&6; };;
+ *)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5
+$as_echo "none" >&6; };;
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
+#------------------------------------------------------------------------------
+# Find out all about time handling differences.
+#------------------------------------------------------------------------------
+
+
+ for ac_header in sys/time.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/time.h" "ac_cv_header_sys_time_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_time_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_SYS_TIME_H 1
_ACEOF
fi
done
- 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether time.h and sys/time.h may both be included" >&5
+$as_echo_n "checking whether time.h and sys/time.h may both be included... " >&6; }
+if ${ac_cv_header_time+:} false; then :
+ $as_echo_n "(cached) " >&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 <sys/time.h>
@@ -13805,164 +8566,42 @@ 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
+if ac_fn_c_try_compile "$LINENO"; 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
+ ac_cv_header_time=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5
-echo "${ECHO_T}$ac_cv_header_time" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_time" >&5
+$as_echo "$ac_cv_header_time" >&6; }
if test $ac_cv_header_time = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define TIME_WITH_SYS_TIME 1
-_ACEOF
+$as_echo "#define TIME_WITH_SYS_TIME 1" >>confdefs.h
fi
-
-
-
-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. */
-
-#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 gmtime_r localtime_r mktime
+do :
+ as_ac_var=`$as_echo "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 `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking tm_tzadj in struct tm" >&5
+$as_echo_n "checking tm_tzadj in struct tm... " >&6; }
+if ${tcl_cv_member_tm_tzadj+:} false; then :
+ $as_echo_n "(cached) " >&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 <time.h>
int
@@ -13973,58 +8612,28 @@ struct tm tm; 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5
-echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_tzadj" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking tm_gmtoff in struct tm" >&5
+$as_echo_n "checking tm_gmtoff in struct tm... " >&6; }
+if ${tcl_cv_member_tm_gmtoff+:} false; then :
+ $as_echo_n "(cached) " >&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 <time.h>
int
@@ -14035,44 +8644,18 @@ struct tm tm; 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5
-echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_gmtoff" >&5
+$as_echo "$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
+$as_echo "#define HAVE_TM_GMTOFF 1" >>confdefs.h
fi
@@ -14080,17 +8663,13 @@ _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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking long timezone variable" >&5
+$as_echo_n "checking long timezone variable... " >&6; }
+if ${tcl_cv_timezone_long+:} false; then :
+ $as_echo_n "(cached) " >&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 <time.h>
int
@@ -14103,60 +8682,30 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5
-echo "${ECHO_T}$tcl_cv_timezone_long" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_long" >&5
+$as_echo "$tcl_cv_timezone_long" >&6; }
if test $tcl_cv_timezone_long = yes ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TIMEZONE_VAR 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking time_t timezone variable" >&5
+$as_echo_n "checking time_t timezone variable... " >&6; }
+if ${tcl_cv_timezone_time+:} false; then :
+ $as_echo_n "(cached) " >&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 <time.h>
int
@@ -14169,44 +8718,18 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5
-echo "${ECHO_T}$tcl_cv_timezone_time" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_time" >&5
+$as_echo "$tcl_cv_timezone_time" >&6; }
if test $tcl_cv_timezone_time = yes ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_TIMEZONE_VAR 1
-_ACEOF
+$as_echo "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h
fi
fi
@@ -14219,108 +8742,8 @@ _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
-
-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
+ 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 >>confdefs.h <<_ACEOF
#define HAVE_STRUCT_STAT_ST_BLOCKS 1
@@ -14328,108 +8751,8 @@ _ACEOF
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
@@ -14439,63 +8762,8 @@ _ACEOF
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_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
+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 :
cat >>confdefs.h <<_ACEOF
#define HAVE_BLKCNT_T 1
@@ -14504,103 +8772,12 @@ _ACEOF
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
-cat >>confdefs.h <<\_ACEOF
-#define NO_FSTATFS 1
-_ACEOF
+$as_echo "#define NO_FSTATFS 1" >>confdefs.h
fi
@@ -14610,19 +8787,15 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for working memcmp" >&5
+$as_echo_n "checking for working memcmp... " >&6; }
+if ${ac_cv_func_memcmp_working+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- if test "$cross_compiling" = yes; then
+ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_includes_default
int
@@ -14630,9 +8803,9 @@ main ()
{
/* 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.
@@ -14648,46 +8821,31 @@ 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
+ 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 "* | \
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_memcmp_working" >&5
+$as_echo "$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
@@ -14698,109 +8856,16 @@ 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
-
-/* 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. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#undef memmove
-
-/* 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_fn_c_check_func "$LINENO" "memmove" "ac_cv_func_memmove"
+if test "x$ac_cv_func_memmove" = xyes; then :
-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
+$as_echo "#define NO_MEMMOVE 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define NO_STRING_H 1
-_ACEOF
+$as_echo "#define NO_STRING_H 1" >>confdefs.h
fi
@@ -14811,150 +8876,43 @@ 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
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strstr implementation" >&5
+$as_echo_n "checking proper strstr implementation... " >&6; }
+if ${tcl_cv_strstr_unbroken+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- if test "$cross_compiling" = yes; then
+ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
int main() {
- extern int strstr();
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
+ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strstr_unbroken" >&5
+$as_echo "$tcl_cv_strstr_unbroken" >&6; }
if test "$tcl_cv_strstr_unbroken" = "ok"; then
tcl_ok=1
else
@@ -14962,12 +8920,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
@@ -14981,151 +8937,44 @@ 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
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strtoul implementation" >&5
+$as_echo_n "checking proper strtoul implementation... " >&6; }
+if ${tcl_cv_strtoul_unbroken+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- if test "$cross_compiling" = yes; then
+ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
int main() {
- extern int strtoul();
char *term, *string = "0";
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
+ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtoul_unbroken" >&5
+$as_echo "$tcl_cv_strtoul_unbroken" >&6; }
if test "$tcl_cv_strtoul_unbroken" = "ok"; then
tcl_ok=1
else
@@ -15133,12 +8982,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
@@ -15150,64 +8997,9 @@ 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
cat >>confdefs.h <<_ACEOF
@@ -15216,64 +9008,9 @@ _ACEOF
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
-/* end confdefs.h. */
-$ac_includes_default
-int
-main ()
-{
-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_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 :
-ac_cv_type_pid_t=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-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
cat >>confdefs.h <<_ACEOF
@@ -15282,88 +9019,29 @@ _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_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 :
-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
cat >>confdefs.h <<_ACEOF
-#define size_t unsigned
+#define size_t unsigned int
_ACEOF
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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for uid_t in sys/types.h" >&5
+$as_echo_n "checking for uid_t in sys/types.h... " >&6; }
+if ${ac_cv_type_uid_t+:} false; then :
+ $as_echo_n "(cached) " >&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>
_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
ac_cv_type_uid_t=no
@@ -15371,33 +9049,25 @@ fi
rm -f conftest*
fi
-echo "$as_me:$LINENO: result: $ac_cv_type_uid_t" >&5
-echo "${ECHO_T}$ac_cv_type_uid_t" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_uid_t" >&5
+$as_echo "$ac_cv_type_uid_t" >&6; }
if test $ac_cv_type_uid_t = no; then
-cat >>confdefs.h <<\_ACEOF
-#define uid_t int
-_ACEOF
+$as_echo "#define uid_t int" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define gid_t int
-_ACEOF
+$as_echo "#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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for socklen_t" >&5
+$as_echo_n "checking for socklen_t... " >&6; }
+if ${tcl_cv_type_socklen_t+:} false; then :
+ $as_echo_n "(cached) " >&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>
@@ -15413,172 +9083,62 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_type_socklen_t" >&5
-echo "${ECHO_T}$tcl_cv_type_socklen_t" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_socklen_t" >&5
+$as_echo "$tcl_cv_type_socklen_t" >&6; }
if test $tcl_cv_type_socklen_t = no; then
-cat >>confdefs.h <<\_ACEOF
-#define socklen_t int
-_ACEOF
+$as_echo "#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_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "$ac_includes_default"
+if test "x$ac_cv_type_intptr_t" = xyes; then :
-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
+$as_echo "#define HAVE_INTPTR_T 1" >>confdefs.h
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size signed integer type" >&5
+$as_echo_n "checking for pointer-size signed integer type... " >&6; }
+if ${tcl_cv_intptr_t+:} false; then :
+ $as_echo_n "(cached) " >&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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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
+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 :
tcl_ok=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
+ tcl_ok=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intptr_t" >&5
+$as_echo "$tcl_cv_intptr_t" >&6; }
if test "$tcl_cv_intptr_t" != none; then
cat >>confdefs.h <<_ACEOF
@@ -15589,132 +9149,48 @@ _ACEOF
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
+ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "$ac_includes_default"
+if test "x$ac_cv_type_uintptr_t" = xyes; then :
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_UINTPTR_T 1
-_ACEOF
+$as_echo "#define HAVE_UINTPTR_T 1" >>confdefs.h
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size unsigned integer type" >&5
+$as_echo_n "checking for pointer-size unsigned integer type... " >&6; }
+if ${tcl_cv_uintptr_t+:} false; then :
+ $as_echo_n "(cached) " >&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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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
+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 :
tcl_ok=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
+ tcl_ok=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_uintptr_t" >&5
+$as_echo "$tcl_cv_uintptr_t" >&6; }
if test "$tcl_cv_uintptr_t" != none; then
cat >>confdefs.h <<_ACEOF
@@ -15733,103 +9209,12 @@ 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
-cat >>confdefs.h <<\_ACEOF
-#define USE_DIRENT2_H 1
-_ACEOF
+$as_echo "#define USE_DIRENT2_H 1" >>confdefs.h
fi
@@ -15842,17 +9227,13 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking union wait" >&5
+$as_echo_n "checking union wait... " >&6; }
+if ${tcl_cv_union_wait+:} false; then :
+ $as_echo_n "(cached) " >&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 <sys/wait.h>
@@ -15868,45 +9249,19 @@ 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
+ 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$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5
-echo "${ECHO_T}$tcl_cv_union_wait" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_union_wait" >&5
+$as_echo "$tcl_cv_union_wait" >&6; }
if test $tcl_cv_union_wait = no; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_UNION_WAIT 1
-_ACEOF
+$as_echo "#define NO_UNION_WAIT 1" >>confdefs.h
fi
@@ -15916,168 +9271,51 @@ 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
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -lsocket" >&5
+$as_echo_n "checking for strncasecmp in -lsocket... " >&6; }
+if ${ac_cv_lib_socket_strncasecmp+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char strncasecmp ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_strncasecmp" >&5
+$as_echo "$ac_cv_lib_socket_strncasecmp" >&6; }
+if test "x$ac_cv_lib_socket_strncasecmp" = xyes; then :
tcl_ok=1
else
tcl_ok=0
@@ -16085,71 +9323,43 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -linet" >&5
+$as_echo_n "checking for strncasecmp in -linet... " >&6; }
+if ${ac_cv_lib_inet_strncasecmp+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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. */
+/* 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
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
char strncasecmp ();
int
main ()
{
-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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_strncasecmp" >&5
+$as_echo "$ac_cv_lib_inet_strncasecmp" >&6; }
+if test "x$ac_cv_lib_inet_strncasecmp" = xyes; then :
tcl_ok=1
else
tcl_ok=0
@@ -16157,12 +9367,10 @@ 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
@@ -16177,125 +9385,30 @@ 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
+ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday"
+if test "x$ac_cv_func_gettimeofday" = xyes; then :
-/* 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. */
-
-#ifdef __STDC__
-# include <limits.h>
-#else
-# include <assert.h>
-#endif
-
-#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
-
-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
+$as_echo "#define NO_GETTOD 1" >>confdefs.h
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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5
+$as_echo_n "checking for gettimeofday declaration... " >&6; }
+if ${tcl_cv_grep_gettimeofday+:} false; then :
+ $as_echo_n "(cached) " >&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
tcl_cv_grep_gettimeofday=missing
@@ -16303,13 +9416,11 @@ fi
rm -f conftest*
fi
-echo "$as_me:$LINENO: result: $tcl_cv_grep_gettimeofday" >&5
-echo "${ECHO_T}$tcl_cv_grep_gettimeofday" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_gettimeofday" >&5
+$as_echo "$tcl_cv_grep_gettimeofday" >&6; }
if test $tcl_cv_grep_gettimeofday = missing ; then
-cat >>confdefs.h <<\_ACEOF
-#define GETTOD_NOT_DECLARED 1
-_ACEOF
+$as_echo "#define GETTOD_NOT_DECLARED 1" >>confdefs.h
fi
@@ -16319,80 +9430,46 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether char is unsigned" >&5
+$as_echo_n "checking whether char is unsigned... " >&6; }
+if ${ac_cv_c_char_unsigned+:} false; then :
+ $as_echo_n "(cached) " >&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. */
$ac_includes_default
int
main ()
{
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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5
-echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_char_unsigned" >&5
+$as_echo "$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
+ $as_echo "#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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking signed char declarations" >&5
+$as_echo_n "checking signed char declarations... " >&6; }
+if ${tcl_cv_char_signed+:} false; then :
+ $as_echo_n "(cached) " >&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. */
int
@@ -16406,44 +9483,18 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5
-echo "${ECHO_T}$tcl_cv_char_signed" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_char_signed" >&5
+$as_echo "$tcl_cv_char_signed" >&6; }
if test $tcl_cv_char_signed = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_SIGNED_CHAR 1
-_ACEOF
+$as_echo "#define HAVE_SIGNED_CHAR 1" >>confdefs.h
fi
@@ -16451,20 +9502,16 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a putenv() that copies the buffer" >&5
+$as_echo_n "checking for a putenv() that copies the buffer... " >&6; }
+if ${tcl_cv_putenv_copy+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
@@ -16487,36 +9534,21 @@ 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
+ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_putenv_copy" >&5
+$as_echo "$tcl_cv_putenv_copy" >&6; }
if test $tcl_cv_putenv_copy = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_PUTENV_THAT_COPIES 1
-_ACEOF
+$as_echo "#define HAVE_PUTENV_THAT_COPIES 1" >>confdefs.h
fi
@@ -16525,154 +9557,18 @@ fi
#--------------------------------------------------------------------
- # Check whether --enable-langinfo or --disable-langinfo was given.
-if test "${enable_langinfo+set}" = set; then
- enableval="$enable_langinfo"
- langinfo_ok=$enableval
+ # Check whether --enable-langinfo was given.
+if test "${enable_langinfo+set}" = set; then :
+ enableval=$enable_langinfo; langinfo_ok=$enableval
else
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_mongrel "$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
langinfo_ok=no
@@ -16680,18 +9576,14 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use nl_langinfo" >&5
+$as_echo_n "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
+ if ${tcl_cv_langinfo_h+:} false; then :
+ $as_echo_n "(cached) " >&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 <langinfo.h>
int
@@ -16702,155 +9594,38 @@ 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
+ 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.$ac_ext
fi
- echo "$as_me:$LINENO: result: $tcl_cv_langinfo_h" >&5
-echo "${ECHO_T}$tcl_cv_langinfo_h" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_langinfo_h" >&5
+$as_echo "$tcl_cv_langinfo_h" >&6; }
if test $tcl_cv_langinfo_h = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_LANGINFO 1
-_ACEOF
+$as_echo "#define HAVE_LANGINFO 1" >>confdefs.h
fi
else
- echo "$as_me:$LINENO: result: $langinfo_ok" >&5
-echo "${ECHO_T}$langinfo_ok" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
+$as_echo "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
-# Check for support of chflags and mkstemps functions
+# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
-
-
-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
+for ac_func in cfmakeraw chflags mkstemps
+do :
+ as_ac_var=`$as_echo "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 `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
fi
@@ -16861,17 +9636,13 @@ done
# 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking isnan" >&5
+$as_echo_n "checking isnan... " >&6; }
+if ${tcl_cv_isnan+:} false; then :
+ $as_echo_n "(cached) " >&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 <math.h>
int
@@ -16884,45 +9655,19 @@ 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
+if ac_fn_c_try_link "$LINENO"; then :
tcl_cv_isnan=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_isnan=no
+ tcl_cv_isnan=no
fi
-rm -f conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
+rm -f core 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_isnan" >&5
+$as_echo "$tcl_cv_isnan" >&6; }
if test $tcl_cv_isnan = no; then
-cat >>confdefs.h <<\_ACEOF
-#define NO_ISNAN 1
-_ACEOF
+$as_echo "#define NO_ISNAN 1" >>confdefs.h
fi
@@ -16931,608 +9676,59 @@ fi
#--------------------------------------------------------------------
if test "`uname -s`" = "Darwin" ; then
-
-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
+ for ac_func in getattrlist
+do :
+ ac_fn_c_check_func "$LINENO" "getattrlist" "ac_cv_func_getattrlist"
+if test "x$ac_cv_func_getattrlist" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+#define HAVE_GETATTRLIST 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
-
-# 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
+ for ac_header in copyfile.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "copyfile.h" "ac_cv_header_copyfile_h" "$ac_includes_default"
+if test "x$ac_cv_header_copyfile_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_COPYFILE_H 1
_ACEOF
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
+ for ac_func in copyfile
+do :
+ ac_fn_c_check_func "$LINENO" "copyfile" "ac_cv_func_copyfile"
+if test "x$ac_cv_func_copyfile" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+#define HAVE_COPYFILE 1
_ACEOF
fi
done
if test $tcl_corefoundation = yes; then
-
-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_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
+ for ac_header in libkern/OSAtomic.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "libkern/OSAtomic.h" "ac_cv_header_libkern_OSAtomic_h" "$ac_includes_default"
+if test "x$ac_cv_header_libkern_OSAtomic_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_LIBKERN_OSATOMIC_H 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
+ for ac_func in OSSpinLockLock
+do :
+ ac_fn_c_check_func "$LINENO" "OSSpinLockLock" "ac_cv_func_OSSpinLockLock"
+if test "x$ac_cv_func_OSSpinLockLock" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1
+#define HAVE_OSSPINLOCKLOCK 1
_ACEOF
fi
@@ -17540,169 +9736,23 @@ done
fi
-cat >>confdefs.h <<\_ACEOF
-#define USE_VFORK 1
-_ACEOF
+$as_echo "#define USE_VFORK 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define TCL_DEFAULT_ENCODING "utf-8"
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define TCL_LOAD_FROM_MEMORY 1
-_ACEOF
-
-
-cat >>confdefs.h <<\_ACEOF
-#define TCL_WIDE_CLICKS 1
-_ACEOF
-
-
-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
+$as_echo "#define TCL_DEFAULT_ENCODING \"utf-8\"" >>confdefs.h
-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
+$as_echo "#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
+$as_echo "#define TCL_WIDE_CLICKS 1" >>confdefs.h
-fi
-if test `eval echo '${'$as_ac_Header'}'` = yes; then
+ for ac_header in AvailabilityMacros.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "AvailabilityMacros.h" "ac_cv_header_AvailabilityMacros_h" "$ac_includes_default"
+if test "x$ac_cv_header_AvailabilityMacros_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_AVAILABILITYMACROS_H 1
_ACEOF
fi
@@ -17710,18 +9760,14 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if weak import is available" >&5
+$as_echo_n "checking if weak import is available... " >&6; }
+if ${tcl_cv_cc_weak_import+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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__
@@ -17741,60 +9787,30 @@ 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
+ 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$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_weak_import" >&5
+$as_echo "$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
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if Darwin SUSv3 extensions are available" >&5
+$as_echo_n "checking if Darwin SUSv3 extensions are available... " >&6; }
+if ${tcl_cv_cc_darwin_c_source+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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__
@@ -17815,45 +9831,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_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
+ 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.$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_darwin_c_source" >&5
+$as_echo "$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
+$as_echo "#define _DARWIN_C_SOURCE 1" >>confdefs.h
fi
fi
@@ -17869,17 +9859,13 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fts" >&5
+$as_echo_n "checking for fts... " >&6; }
+if ${tcl_cv_api_fts+:} false; then :
+ $as_echo_n "(cached) " >&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/param.h>
@@ -17898,45 +9884,19 @@ 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
+ 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$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_api_fts" >&5
-echo "${ECHO_T}$tcl_cv_api_fts" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_fts" >&5
+$as_echo "$tcl_cv_api_fts" >&6; }
if test $tcl_cv_api_fts = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_FTS 1
-_ACEOF
+$as_echo "#define HAVE_FTS 1" >>confdefs.h
fi
@@ -17947,300 +9907,24 @@ fi
#--------------------------------------------------------------------
-
-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
+ for ac_header in sys/ioctl.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_ioctl_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_SYS_IOCTL_H 1
_ACEOF
fi
done
-
-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
+ for ac_header in sys/filio.h
+do :
+ ac_fn_c_check_header_mongrel "$LINENO" "sys/filio.h" "ac_cv_header_sys_filio_h" "$ac_includes_default"
+if test "x$ac_cv_header_sys_filio_h" = xyes; then :
cat >>confdefs.h <<_ACEOF
-#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+#define HAVE_SYS_FILIO_H 1
_ACEOF
fi
@@ -18248,27 +9932,21 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking system version" >&5
+$as_echo_n "checking system version... " >&6; }
+if ${tcl_cv_sys_version+:} false; then :
+ $as_echo_n "(cached) " >&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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
+$as_echo "$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
@@ -18279,58 +9957,45 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
+$as_echo_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; }
case $system in
OSF*)
-cat >>confdefs.h <<\_ACEOF
-#define USE_FIONBIO 1
-_ACEOF
-
- echo "$as_me:$LINENO: result: FIONBIO" >&5
-echo "${ECHO_T}FIONBIO" >&6
- ;;
- SunOS-4*)
-
-cat >>confdefs.h <<\_ACEOF
-#define USE_FIONBIO 1
-_ACEOF
+$as_echo "#define USE_FIONBIO 1" >>confdefs.h
- echo "$as_me:$LINENO: result: FIONBIO" >&5
-echo "${ECHO_T}FIONBIO" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5
+$as_echo "FIONBIO" >&6; }
;;
*)
- echo "$as_me:$LINENO: result: O_NONBLOCK" >&5
-echo "${ECHO_T}O_NONBLOCK" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use dll unloading" >&5
+$as_echo_n "checking whether to use dll unloading... " >&6; }
+# Check whether --enable-dll-unloading was given.
+if test "${enable_dll_unloading+set}" = set; then :
+ enableval=$enable_dll_unloading; tcl_ok=$enableval
else
tcl_ok=yes
-fi;
+fi
+
if test $tcl_ok = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define TCL_UNLOAD_DLLS 1
-_ACEOF
+$as_echo "#define TCL_UNLOAD_DLLS 1" >>confdefs.h
fi
-echo "$as_me:$LINENO: result: $tcl_ok" >&5
-echo "${ECHO_T}$tcl_ok" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
+$as_echo "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
@@ -18338,31 +10003,31 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for timezone data" >&5
+$as_echo_n "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
+# Check whether --with-tzdata was given.
+if test "${with_tzdata+set}" = set; then :
+ withval=$with_tzdata; tcl_ok=$withval
else
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: supplied by OS vendor" >&5
+$as_echo "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
+ if ${tcl_cv_dir_zoneinfo+:} false; then :
+ $as_echo_n "(cached) " >&6
else
for dir in /usr/share/zoneinfo \
@@ -18379,22 +10044,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $dir" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: supplied by Tcl" >&5
+$as_echo "supplied by Tcl" >&6; }
INSTALL_TZDATA=install-tzdata
fi
@@ -18402,152 +10065,16 @@ 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
+# Check whether --enable-dtrace was given.
+if test "${enable_dtrace+set}" = set; then :
+ enableval=$enable_dtrace; tcl_ok=$enableval
else
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_mongrel "$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
tcl_ok=no
@@ -18558,10 +10085,10 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_path_DTRACE+:} false; then :
+ $as_echo_n "(cached) " >&6
else
case $DTRACE in
[\\/]* | ?:[\\/]*)
@@ -18574,38 +10101,37 @@ 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
+ 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"
- echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $DTRACE" >&5
+$as_echo "$DTRACE" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to enable DTrace support" >&5
+$as_echo_n "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
+$as_echo "#define USE_DTRACE 1" >>confdefs.h
DTRACE_SRC="\${DTRACE_SRC}"
DTRACE_HDR="\${DTRACE_HDR}"
@@ -18623,24 +10149,185 @@ _ACEOF
fi
fi
fi
-echo "$as_me:$LINENO: result: $tcl_ok" >&5
-echo "${ECHO_T}$tcl_ok" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
+$as_echo "$tcl_ok" >&6; }
+
+#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+# Check whether --enable-zipfs was given.
+if test "${enable_zipfs+set}" = set; then :
+ enableval=$enable_zipfs; tcl_ok=$enableval
+else
+ tcl_ok=yes
+fi
+
+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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
+$as_echo_n "checking for gcc... " >&6; }
+ if ${ac_cv_path_cc+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+
+ 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'
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
+$as_echo_n "checking for build system executable suffix... " >&6; }
+if ${bfd_cv_build_exeext+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
+$as_echo "$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
+ #
+
+ ZIP_PROG=""
+ ZIP_PROG_OPTIONS=""
+ ZIP_PROG_VFSSEARCH=""
+ ZIP_INSTALL_OBJS=""
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
+$as_echo_n "checking for zip... " >&6; }
+ if ${ac_cv_path_zip+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+
+ 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"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
+$as_echo "$ZIP_PROG" >&6; }
+ ZIP_PROG_OPTIONS="-rq"
+ ZIP_PROG_VFSSEARCH="*"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
+$as_echo "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}"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH. Building minizip" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
+$as_echo_n "checking for building with zipfs... " >&6; }
+if test "${ZIPFS_BUILD}" = 1; then
+ if test "${SHARED_BUILD}" = 0; then
+ ZIPFS_BUILD=2;
+
+$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h
+
+ INSTALL_LIBRARIES=install-libraries-zipfs-static
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+ else
+
+$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h
+\
+ INSTALL_LIBRARIES=install-libraries-zipfs-shared
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+ fi
+else
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+INSTALL_LIBRARIES=install-libraries
+INSTALL_MSGS=install-msgs
+fi
+
+
+
+
+
#--------------------------------------------------------------------
# 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the cpuid instruction is usable" >&5
+$as_echo_n "checking whether the cpuid instruction is usable... " >&6; }
+if ${tcl_cv_cpuid+:} false; then :
+ $as_echo_n "(cached) " >&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. */
int
@@ -18659,45 +10346,19 @@ 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
+ 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$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cpuid" >&5
-echo "${ECHO_T}$tcl_cv_cpuid" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cpuid" >&5
+$as_echo "$tcl_cv_cpuid" >&6; }
if test $tcl_cv_cpuid = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_CPUID 1
-_ACEOF
+$as_echo "#define HAVE_CPUID 1" >>confdefs.h
fi
@@ -18728,38 +10389,38 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to package libraries" >&5
+$as_echo_n "checking how to package libraries... " >&6; }
+ # Check whether --enable-framework was given.
+if test "${enable_framework+set}" = set; then :
+ enableval=$enable_framework; enable_framework=$enableval
else
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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be built if --enable-shared is yes" >&5
+$as_echo "$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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be used when CoreFoundation is available" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: framework" >&5
+$as_echo "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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared library" >&5
+$as_echo "shared library" >&6; }
else
- echo "$as_me:$LINENO: result: static library" >&5
-echo "${ECHO_T}static library" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: static library" >&5
+$as_echo "static library" >&6; }
fi
FRAMEWORK_BUILD=0
fi
@@ -18771,20 +10432,18 @@ echo "${ECHO_T}static library" >&6
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
+$as_echo "#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
@@ -18944,7 +10603,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
@@ -18964,39 +10624,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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$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
+ :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
+ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
+$as_echo "$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"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
+$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
@@ -19005,63 +10696,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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
+$as_echo "$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.
@@ -19071,81 +10755,253 @@ 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
+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
+ # 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
+ 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
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
+else
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
+fi
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; 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
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# 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
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
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
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+
+# 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
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
-done
+ $as_echo "$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_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_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 ||
+$as_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'
@@ -19153,148 +11009,111 @@ 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= ;;
+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
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
else
- as_expr=false
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
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
+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=`$as_echo "$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 ||
+$as_echo 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'"
@@ -19303,31 +11122,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.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
@@ -19335,43 +11143,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
@@ -19379,83 +11185,78 @@ $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
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
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.69,
+ with options \\"\$ac_cs_config\\"
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2012 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 )
+ $as_echo "$ac_cs_version"; exit ;;
+ --config | --confi | --conf | --con | --co | --c )
+ $as_echo "$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=`$as_echo "$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 )
+ $as_echo "$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
@@ -19469,43 +11270,55 @@ 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
+ \$as_echo "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
+ $as_echo "$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
@@ -19516,533 +11329,427 @@ if $ac_need_defaults; then
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
+
+# 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
-cat >>$CONFIG_STATUS <<_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
+fi # test -n "$CONFIG_FILES"
-#
-# 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,@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,@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,@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
+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
-_ACEOF
+ 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=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
+ as_fn_append ac_file_inputs " '$ac_f'"
+ done
- 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
+ # 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 '`
+ $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
+ `' by configure.'
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
+$as_echo "$as_me: creating $ac_file" >&6;}
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"
+ # Neutralize special characters interpreted by sed in replacement strings.
+ case $configure_input in #(
+ *\&* | *\|* | *\\* )
+ ac_sed_conf_input=`$as_echo "$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 ||
+$as_echo 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$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;;
+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@*)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+$as_echo "$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
-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
+
+# 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"; } &&
+ { $as_echo "$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
+$as_echo "$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) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5
+$as_echo "$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.
@@ -20062,7 +11769,11 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
+$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
diff --git a/unix/configure.in b/unix/configure.ac
index 9dd9b7f..d480fb7 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], [
@@ -22,10 +22,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=".10"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a4"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
@@ -86,10 +86,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 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
# Do this early, otherwise an autoconf bug throws errors on configure
@@ -120,12 +121,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
#------------------------------------------------------------------------
@@ -172,6 +167,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,
+AC_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
@@ -182,7 +201,6 @@ SC_CONFIG_CFLAGS
SC_ENABLE_SYMBOLS(bccdebug)
-AC_DEFINE(TCL_TOMMATH, 1, [Build libtommath?])
AC_DEFINE(MP_PREC, 4, [Default libtommath precision.])
#--------------------------------------------------------------------
@@ -216,7 +234,7 @@ AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])])
AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])])
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
@@ -230,35 +248,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
#---------------------------------------------------------------------------
@@ -301,6 +317,36 @@ if test $tcl_ok = no; then
AC_DEFINE(NO_FD_SET, 1, [Do we have fd_set?])
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.
#------------------------------------------------------------------------------
@@ -342,7 +388,6 @@ AC_CHECK_FUNC(memmove, , [
#--------------------------------------------------------------------
SC_TCL_CHECK_BROKEN_FUNC(strstr, [
- extern int strstr();
exit(strstr("\0test", "test") ? 1 : 0);
])
@@ -353,7 +398,6 @@ SC_TCL_CHECK_BROKEN_FUNC(strstr, [
#--------------------------------------------------------------------
SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
- extern int strtoul();
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
])
@@ -532,10 +576,10 @@ fi
SC_ENABLE_LANGINFO
#--------------------------------------------------------------------
-# Check for support of chflags and mkstemps functions
+# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
-AC_CHECK_FUNCS(chflags mkstemps)
+AC_CHECK_FUNCS(cfmakeraw chflags mkstemps)
#--------------------------------------------------------------------
# Check for support of isnan() function or macro
@@ -742,6 +786,52 @@ fi
AC_MSG_RESULT([$tcl_ok])
#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+AC_ARG_ENABLE(zipfs,
+ AC_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_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?])
+ INSTALL_LIBRARIES=install-libraries-zipfs-static
+ AC_MSG_RESULT([yes])
+ else
+ AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\
+ INSTALL_LIBRARIES=install-libraries-zipfs-shared
+ AC_MSG_RESULT([yes])
+ fi
+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 check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
@@ -911,6 +1001,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..500bf97 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
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c
index c4d3f32..5bf3c1e 100644
--- a/unix/dltest/pkga.c
+++ b/unix/dltest/pkga.c
@@ -14,14 +14,6 @@
#include "tcl.h"
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Pkga_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
* Prototypes for procedures defined later in this file:
*/
@@ -124,14 +116,14 @@ Pkga_QuoteObjCmd(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkga_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkga", "1.0");
diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c
index 557f21b..983fcf3 100644
--- a/unix/dltest/pkgc.c
+++ b/unix/dltest/pkgc.c
@@ -15,14 +15,6 @@
#include "tcl.h"
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Pkgc_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
* Prototypes for procedures defined later in this file:
*/
@@ -114,14 +106,14 @@ Pkgc_UnsafeObjCmd(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgc_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
@@ -151,14 +143,14 @@ Pkgc_Init(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgc_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c
index 6e114e9..c708df0 100644
--- a/unix/dltest/pkgd.c
+++ b/unix/dltest/pkgd.c
@@ -15,14 +15,6 @@
#include "tcl.h"
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Pkgd_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
* Prototypes for procedures defined later in this file:
*/
@@ -114,14 +106,14 @@ Pkgd_UnsafeObjCmd(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgd_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
@@ -151,14 +143,14 @@ Pkgd_Init(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgd_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c
index 395cd0e..f46ca74 100644
--- a/unix/dltest/pkge.c
+++ b/unix/dltest/pkge.c
@@ -13,15 +13,6 @@
#undef STATIC_BUILD
#include "tcl.h"
-
-/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Pkge_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
/*
*----------------------------------------------------------------------
@@ -40,14 +31,14 @@
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkge_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
static const char script[] = "if 44 {open non_existent}";
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, script, -1, 0);
diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c
index 78af376..5a0b0ef 100644
--- a/unix/dltest/pkgooa.c
+++ b/unix/dltest/pkgooa.c
@@ -96,7 +96,7 @@ Pkgooa_Init(
* This worked in Tcl 8.6.0, and is expected
* to keep working in all future Tcl 8.x releases.
*/
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (tclStubsPtr == NULL) {
diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c
index 417bedb..9d5a9d9 100644
--- a/unix/dltest/pkgua.c
+++ b/unix/dltest/pkgua.c
@@ -11,18 +11,9 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#undef STATIC_BUILD
#include "tcl.h"
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Pkgua_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
* Prototypes for procedures defined later in this file:
*/
@@ -78,7 +69,7 @@ PkguaInterpToTokens(
int newEntry;
Tcl_Command *cmdTokens;
Tcl_HashEntry *entryPtr =
- Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry);
+ Tcl_CreateHashEntry(&interpTokenMap, interp, &newEntry);
if (newEntry) {
cmdTokens = (Tcl_Command *)
@@ -98,7 +89,7 @@ PkguaDeleteTokens(
Tcl_Interp *interp)
{
Tcl_HashEntry *entryPtr =
- Tcl_FindHashEntry(&interpTokenMap, (char *) interp);
+ Tcl_FindHashEntry(&interpTokenMap, interp);
if (entryPtr) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
@@ -200,7 +191,7 @@ PkguaQuoteObjCmd(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgua_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
@@ -208,7 +199,7 @@ Pkgua_Init(
int code, cmdIndex = 0;
Tcl_Command *cmdTokens;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
@@ -224,7 +215,7 @@ Pkgua_Init(
return code;
}
- Tcl_SetVar(interp, "::pkgua_loaded", ".", TCL_APPEND_VALUE);
+ Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);
cmdTokens = PkguaInterpToTokens(interp);
cmdTokens[cmdIndex++] =
@@ -253,7 +244,7 @@ Pkgua_Init(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgua_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
@@ -278,7 +269,7 @@ Pkgua_SafeInit(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgua_Unload(
Tcl_Interp *interp, /* Interpreter from which the package is to be
* unloaded. */
@@ -299,7 +290,7 @@ Pkgua_Unload(
PkguaDeleteTokens(interp);
- Tcl_SetVar(interp, "::pkgua_detached", ".", TCL_APPEND_VALUE);
+ Tcl_SetVar2(interp, "::pkgua_detached", NULL, ".", TCL_APPEND_VALUE);
if (flags == TCL_UNLOAD_DETACH_FROM_PROCESS) {
/*
@@ -309,7 +300,7 @@ Pkgua_Unload(
*/
PkguaFreeTokensHashTable();
- Tcl_SetVar(interp, "::pkgua_unloaded", ".", TCL_APPEND_VALUE);
+ Tcl_SetVar2(interp, "::pkgua_unloaded", NULL, ".", TCL_APPEND_VALUE);
}
return TCL_OK;
}
@@ -331,7 +322,7 @@ Pkgua_Unload(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgua_SafeUnload(
Tcl_Interp *interp, /* Interpreter from which the package is to be
* unloaded. */
diff --git a/unix/installManPage b/unix/installManPage
index 1af3f6d..06f4f2b 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 25a01ac..056cf1f 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)`"
@@ -527,6 +527,7 @@ AC_DEFUN([SC_ENABLE_SHARED], [
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
fi
+ AC_SUBST(SHARED_BUILD)
])
#------------------------------------------------------------------------
@@ -578,113 +579,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,
- AC_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.
@@ -873,8 +767,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
@@ -883,25 +776,18 @@ AC_DEFUN([SC_CONFIG_MANPAGES], [
# Defines the following var:
#
# system - System/platform/version identification code.
-#
#--------------------------------------------------------------------
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
@@ -964,8 +850,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.
@@ -1080,7 +966,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 -Wwrite-strings -Wpointer-arith"
+ case "${CC}" in
+ *++|*++-*)
+ ;;
+ *)
+ CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
+ ;;
+ esac
+
], [
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
@@ -1091,10 +985,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\ *)
@@ -1189,8 +1083,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
- CYGWIN_*|MINGW32*)
- SHLIB_CFLAGS=""
+ CYGWIN_*)
+ SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
@@ -1215,9 +1109,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"
@@ -1378,7 +1269,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
])
;;
Linux*|GNU*|NetBSD-Debian)
- SHLIB_CFLAGS="-fPIC"
+ SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
@@ -1408,7 +1299,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.
@@ -1427,27 +1318,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
@@ -1465,15 +1335,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
@@ -1489,16 +1357,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}
- 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"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
- SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]"
SHLIB_SUFFIX=".so"
@@ -1507,11 +1372,10 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
- AS_IF([test "${TCL_THREADS}" = "1"], [
- # The -pthread needs to go in the LDFLAGS, not LIBS
- LIBS=`echo $LIBS | sed s/-pthread//`
- CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
- LDFLAGS="$LDFLAGS $PTHREAD_LIBS"])
+ # The -pthread needs to go in the LDFLAGS, not LIBS
+ LIBS=`echo $LIBS | sed s/-pthread//`
+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
+ LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
@@ -1657,47 +1521,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=""
@@ -1715,22 +1544,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"
@@ -1745,11 +1571,11 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
AS_IF([test "$GCC" = yes], [
- SHLIB_CFLAGS="-fPIC -melf"
- LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
+ SHLIB_CFLAGS="-fPIC -melf"
+ LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
], [
- SHLIB_CFLAGS="-Kpic -belf"
- LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
+ SHLIB_CFLAGS="-Kpic -belf"
+ LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
])
SHLIB_LD="ld -G"
SHLIB_LD_LIBS=""
@@ -1759,35 +1585,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
@@ -1987,9 +1784,12 @@ dnl # preprocessing tests use only CPPFLAGS.
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
- IRIX*) ;;
- NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;;
+ HP_UX*) ;;
Darwin-*) ;;
+ IRIX*) ;;
+ Linux*|GNU*) ;;
+ NetBSD-*|OpenBSD-*) ;;
+ OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac])
@@ -2059,6 +1859,8 @@ dnl # preprocessing tests use only CPPFLAGS.
[Defined when compiler supports casting to union type.])
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
# would use TCL_DL_LIBS instead of TCL_LIBS.
@@ -2102,8 +1904,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
#
@@ -2114,8 +1916,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
@@ -2152,12 +1952,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
@@ -2296,10 +2093,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])
;;
@@ -2378,13 +2171,20 @@ AC_DEFUN([SC_TIME_HANDLER], [
#
# Search for the libraries needed to link the Tcl shell.
# Things like the math library (-lm) and socket stuff (-lsocket vs.
-# -lnsl) are dealt with here.
+# -lnsl) 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
@@ -2442,6 +2242,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>]])
])
#--------------------------------------------------------------------
@@ -2517,15 +2366,15 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [
# See if the compiler knows natively about __int64
AC_TRY_COMPILE(,[__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_TRY_COMPILE(,[switch (0) {
case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ;
}],tcl_cv_type_64bit=${tcl_type_64bit})])
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, [Do 'long' and 'long long' have the same size (64-bit)?])
+ 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?])
@@ -3074,6 +2923,129 @@ 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:
+# 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)
+])
+
# Local Variables:
# mode: autoconf
# End:
diff --git a/unix/tcl.pc.in b/unix/tcl.pc.in
index 846cb11..a343707 100644
--- a/unix/tcl.pc.in
+++ b/unix/tcl.pc.in
@@ -4,12 +4,14 @@ prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@
+libfile=@TCL_LIB_FILE@
+zipfile=@TCL_ZIP_FILE@
Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
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 e050a30..e148f36 100644
--- a/unix/tcl.spec
+++ b/unix/tcl.spec
@@ -4,7 +4,7 @@
Name: tcl
Summary: Tcl scripting language development environment
-Version: 8.6.10
+Version: 8.7a3
Release: 2
License: BSD
Group: Development/Languages
diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c
index 9bbc88b..3587f35 100644
--- a/unix/tclAppInit.c
+++ b/unix/tclAppInit.c
@@ -79,6 +79,8 @@ main(
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
+#else
+ TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index ce9c8d0..fb29a32 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -16,6 +16,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 +42,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
@@ -186,6 +196,9 @@
/* 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
@@ -225,6 +238,15 @@
/* Define to 1 if `st_blocks' is 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
@@ -285,15 +307,18 @@
/* No Compiler support for module scope symbols */
#undef MODULE_SCOPE
-/* Default libtommath precision. */
-#undef MP_PREC
-
/* Is no debugging enabled? */
#undef NDEBUG
/* 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 +331,6 @@
/* Do we have fd_set? */
#undef NO_FD_SET
-/* Do we have <float.h>? */
-#undef NO_FLOAT_H
-
/* Do we have fstatfs()? */
#undef NO_FSTATFS
@@ -345,9 +367,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
@@ -402,19 +421,13 @@
/* 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? */
@@ -435,9 +448,6 @@
/* 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
@@ -445,6 +455,9 @@
first (like Motorola and SPARC, unlike Intel and VAX). */
#undef WORDS_BIGENDIAN
+/* Are we building with zipfs enabled? */
+#undef ZIPFS_BUILD
+
/* Are Darwin SUSv3 extensions available? */
#undef _DARWIN_C_SOURCE
diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in
index f768690..743b5a5 100644
--- a/unix/tclConfig.sh.in
+++ b/unix/tclConfig.sh.in
@@ -39,6 +39,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 +69,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 +167,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..406b7ca
--- /dev/null
+++ b/unix/tclEpollNotfy.c
@@ -0,0 +1,837 @@
+/*
+ * 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 (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright (c) 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
+ * PlatformEventsFinalize. */
+#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. */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * Forward declarations.
+ */
+
+static void PlatformEventsControl(FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr, int op, int isNew);
+static void PlatformEventsFinalize(void);
+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 API.
+ */
+
+#include "tclUnixNotfy.c"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitNotifier --
+ *
+ * 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
+Tcl_InitNotifier(void)
+{
+ if (tclNotifierHooks.initNotifierProc) {
+ return tclNotifierHooks.initNotifierProc();
+ } else {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ PlatformEventsInit();
+ return tsdPtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FinalizeNotifier --
+ *
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If no finalizeNotifierProc notifier hook exists, PlatformEvents-
+ * Finalize is called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FinalizeNotifier(
+ ClientData clientData)
+{
+ if (tclNotifierHooks.finalizeNotifierProc) {
+ tclNotifierHooks.finalizeNotifierProc(clientData);
+ return;
+ } else {
+ PlatformEventsFinalize();
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+PlatformEventsControl(
+ FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr,
+ int op,
+ int isNew)
+{
+ struct epoll_event newEvent;
+ struct PlatformEventData *newPedPtr;
+ struct stat 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 (fstat(filePtr->fd, &fdStat) == -1) {
+ Tcl_Panic("fstat: %s", strerror(errno));
+ } else if ((fdStat.st_mode & S_IFMT) == S_IFREG) {
+ 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;
+ }
+ return;
+ } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) {
+ Tcl_Panic("epoll_ctl: %s", strerror(errno));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsFinalize --
+ *
+ * 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
+PlatformEventsFinalize(
+ void)
+{
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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;
+ }
+ }
+ return numFound;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateFileHandler --
+ *
+ * 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
+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. */
+{
+ int isNew;
+
+ 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;
+ isNew = 1;
+ } else {
+ isNew = 0;
+ }
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+ filePtr->mask = mask;
+
+ PlatformEventsControl(filePtr, tsdPtr,
+ isNew ? EPOLL_CTL_ADD : EPOLL_CTL_MOD, isNew);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteFileHandler --
+ *
+ * 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
+Tcl_DeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ if (tclNotifierHooks.deleteFileHandlerProc) {
+ tclNotifierHooks.deleteFileHandlerProc(fd);
+ return;
+ } else {
+ FileHandler *filePtr, *prevPtr;
+ 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.
+ */
+
+ 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);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitForEvent --
+ *
+ * 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.
+ *
+ * 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
+Tcl_WaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ if (tclNotifierHooks.waitForEventProc) {
+ return tclNotifierHooks.waitForEventProc(timePtr);
+ } else {
+ FileHandler *filePtr;
+ int mask;
+ Tcl_Time vTime;
+ /*
+ * 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.
+ */
+
+ struct timeval timeout, *timeoutPtr;
+ int 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;
+ tclScaleTimeProcPtr(&vTime, tclTimeClientData);
+ 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(
+ "Tcl_WaitForEvent: read from %p->triggerEventFd: %s",
+ (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(
+ "Tcl_WaitForEvent: read from %p->triggerPipe[0]: %s",
+ (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;
+ }
+}
+
+#endif /* NOTIFIER_EPOLL && TCL_THREADS */
+#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..4daab7c
--- /dev/null
+++ b/unix/tclKqueueNotfy.c
@@ -0,0 +1,853 @@
+/*
+ * 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 (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright (c) 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;
+ 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
+ * PlatformEventsFinalize. */
+ 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. */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * Forward declarations of internal functions.
+ */
+
+static void PlatformEventsControl(FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr, int op, int isNew);
+static void PlatformEventsFinalize(void);
+static void PlatformEventsInit(void);
+static int PlatformEventsTranslate(struct kevent *eventPtr);
+static int PlatformEventsWait(struct kevent *events,
+ size_t numEvents, struct timeval *timePtr);
+
+#include "tclUnixNotfy.c"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitNotifier --
+ *
+ * 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
+Tcl_InitNotifier(void)
+{
+ if (tclNotifierHooks.initNotifierProc) {
+ return tclNotifierHooks.initNotifierProc();
+ } else {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ PlatformEventsInit();
+ return tsdPtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FinalizeNotifier --
+ *
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If no finalizeNotifierProc notifier hook exists, PlatformEvents-
+ * Finalize is called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FinalizeNotifier(
+ ClientData clientData)
+{
+ if (tclNotifierHooks.finalizeNotifierProc) {
+ tclNotifierHooks.finalizeNotifierProc(clientData);
+ return;
+ } else {
+ PlatformEventsFinalize();
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.)
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+PlatformEventsControl(
+ FileHandler *filePtr,
+ ThreadSpecificData *tsdPtr,
+ int op,
+ int isNew)
+{
+ int numChanges;
+ struct kevent changeList[2];
+ struct PlatformEventData *newPedPtr;
+ struct stat 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 (fstat(filePtr->fd, &fdStat) == -1) {
+ Tcl_Panic("fstat: %s", strerror(errno));
+ } else if ((fdStat.st_mode & S_IFMT) == S_IFREG) {
+ 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;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsFinalize --
+ *
+ * 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
+PlatformEventsFinalize(
+ void)
+{
+ 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));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PlatformEventsInit --
+ *
+ * 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:
+ * None.
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+PlatformEventsInit(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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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;
+ }
+ }
+ return numFound;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateFileHandler --
+ *
+ * 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
+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. */
+{
+ int isNew;
+
+ 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;
+ isNew = 1;
+ } else {
+ isNew = 0;
+ }
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+ filePtr->mask = mask;
+
+ PlatformEventsControl(filePtr, tsdPtr, EV_ADD, isNew);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteFileHandler --
+ *
+ * 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
+Tcl_DeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ if (tclNotifierHooks.deleteFileHandlerProc) {
+ tclNotifierHooks.deleteFileHandlerProc(fd);
+ return;
+ } else {
+ FileHandler *filePtr, *prevPtr;
+ 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.
+ */
+
+ 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);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitForEvent --
+ *
+ * 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.
+ *
+ * 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
+Tcl_WaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ if (tclNotifierHooks.waitForEventProc) {
+ return tclNotifierHooks.waitForEventProc(timePtr);
+ } else {
+ FileHandler *filePtr;
+ int mask;
+ Tcl_Time vTime;
+ /*
+ * 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.
+ */
+
+ struct timeval timeout, *timeoutPtr;
+ 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;
+ tclScaleTimeProcPtr(&vTime, tclTimeClientData);
+ 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 PlatformEvents-
+ * Wait() 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;
+ }
+}
+
+#endif /* NOTIFIER_KQUEUE && TCL_THREADS */
+#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 88e6b50..fea9494 100644
--- a/unix/tclLoadAix.c
+++ b/unix/tclLoadAix.c
@@ -98,7 +98,7 @@ dlopen(
const char *path,
int mode)
{
- register ModulePtr mp;
+ ModulePtr mp;
static void *mainModule;
/*
@@ -134,7 +134,7 @@ dlopen(
return NULL;
}
- mp->name = malloc((unsigned) (strlen(path) + 1));
+ mp->name = malloc(strlen(path) + 1);
strcpy(mp->name, path);
/*
@@ -191,7 +191,7 @@ dlopen(
*/
if (mode & RTLD_GLOBAL) {
- register ModulePtr mp1;
+ ModulePtr mp1;
for (mp1 = mp->next; mp1; mp1 = mp1->next) {
if (loadbind(0, mp1->entry, mp->entry) == -1) {
@@ -243,7 +243,7 @@ static void
caterr(
char *s)
{
- register char *p = s;
+ char *p = s;
while (*p >= '0' && *p <= '9') {
p++;
@@ -282,9 +282,9 @@ dlsym(
void *handle,
const char *symbol)
{
- register ModulePtr mp = (ModulePtr)handle;
- register ExportPtr ep;
- register int i;
+ ModulePtr mp = (ModulePtr)handle;
+ ExportPtr ep;
+ int i;
/*
* Could speed up the search, but I assume that one assigns the result to
@@ -317,9 +317,9 @@ int
dlclose(
void *handle)
{
- register ModulePtr mp = (ModulePtr)handle;
+ ModulePtr mp = (ModulePtr)handle;
int result;
- register ModulePtr mp1;
+ ModulePtr mp1;
if (--mp->refCnt > 0) {
return 0;
@@ -343,8 +343,8 @@ dlclose(
}
if (mp->exports) {
- register ExportPtr ep;
- register int i;
+ ExportPtr ep;
+ int i;
for (ep = mp->exports, i = mp->nExports; i; i--, ep++) {
if (ep->name) {
free(ep->name);
@@ -541,7 +541,7 @@ readExports(
tmpsym[SYMNMLEN] = '\0';
symname = tmpsym;
}
- ep->name = malloc((unsigned) (strlen(symname) + 1));
+ ep->name = malloc(strlen(symname) + 1);
strcpy(ep->name, symname);
ep->addr = (void *)((unsigned long)
mp->entry + ls->l_value - shdata.s_vaddr);
diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index aec071c..07fd30b 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -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]
*/
@@ -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;
@@ -188,6 +188,31 @@ FindSymbol(
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
+#ifdef __cplusplus
+ if (proc == NULL) {
+ char buf[32];
+ sprintf(buf, "%d", Tcl_DStringLength(&ds));
+ Tcl_DStringInit(&newName);
+ TclDStringAppendLiteral(&newName, "__Z");
+ Tcl_DStringAppend(&newName, buf, -1);
+ Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), -1);
+ 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.
*
*----------------------------------------------------------------------
*/
@@ -257,10 +281,8 @@ UnloadFile(
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. */
+ TCL_UNUSED(const char *) /*fileName*/,
+ TCL_UNUSED(Tcl_DString *))
{
return 0;
}
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index e998bf9..e95d269 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -183,7 +183,7 @@ TclpDlopen(
* relative path.
*/
- nativePath = Tcl_FSGetNativePath(pathPtr);
+ nativePath = (const char *)Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr),
-1, &ds);
@@ -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;
@@ -334,7 +334,7 @@ FindSymbol(
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
const char *symbol) /* Symbol name to look up. */
{
- Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
+ Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
Tcl_PackageInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
@@ -343,7 +343,7 @@ FindSymbol(
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
- proc = dlsym(dyldLoadHandle->dlHandle, native);
+ proc = (Tcl_PackageInitProc *)dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
@@ -381,7 +381,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;
@@ -399,7 +399,7 @@ FindSymbol(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
- proc = NSAddressOfSymbol(nsSymbol);
+ proc = (Tcl_PackageInitProc *)NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
@@ -411,7 +411,7 @@ FindSymbol(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
- return proc;
+ return (void *)proc;
}
/*
@@ -440,7 +440,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
@@ -486,10 +486,8 @@ UnloadFile(
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. */
+ TCL_UNUSED(const char *) /*fileName*/,
+ TCL_UNUSED(Tcl_DString *) /*bufPtr*/)
{
return 0;
}
@@ -513,7 +511,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;
@@ -588,7 +586,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;
@@ -617,18 +615,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;
@@ -638,7 +636,7 @@ TclpLoadMemory(
* Thin binary
*/
- mh = buffer;
+ mh = (const struct mach_header_64 *)buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
@@ -693,14 +691,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..8c62784 100644
--- a/unix/tclLoadNext.c
+++ b/unix/tclLoadNext.c
@@ -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;
diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c
index 377ed28..bbcaa66 100644
--- a/unix/tclLoadOSF.c
+++ b/unix/tclLoadOSF.c
@@ -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;
diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c
index 4be3d7b..a92ddf5 100644
--- a/unix/tclLoadShl.c
+++ b/unix/tclLoadShl.c
@@ -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;
diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c
new file mode 100644
index 0000000..5f30857
--- /dev/null
+++ b/unix/tclSelectNotfy.c
@@ -0,0 +1,1124 @@
+/*
+ * 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 (c) 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;
+
+/*
+ * 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.
+ */
+
+#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:
+ */
+
+static const wchar_t className[] = L"TclNotifier";
+static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
+ void *wParam, void *lParam);
+#ifdef __cplusplus
+}
+#endif
+#endif /* TCL_THREADS && __CYGWIN__ */
+
+
+#include "tclUnixNotfy.c"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitNotifier --
+ *
+ * Initializes the platform specific notifier state.
+ *
+ * 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 {
+ 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
+ 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: pthread_atfork failed");
+ }
+ atForkInit = 1;
+ }
+#endif /* HAVE_PTHREAD_ATFORK */
+
+ notifierCount++;
+ pthread_mutex_unlock(&notifierInitMutex);
+
+#endif /* TCL_THREADS */
+ return tsdPtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FinalizeNotifier --
+ *
+ * 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
+Tcl_FinalizeNotifier(
+ ClientData clientData)
+{
+ if (tclNotifierHooks.finalizeNotifierProc) {
+ tclNotifierHooks.finalizeNotifierProc(clientData);
+ return;
+ } else {
+#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;
+ }
+ }
+
+ /*
+ * 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_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. */
+ ClientData 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);
+ }
+}
+
+#if 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__ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitForEvent --
+ *
+ * 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
+Tcl_WaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ if (tclNotifierHooks.waitForEventProc) {
+ return tclNotifierHooks.waitForEventProc(timePtr);
+ } else {
+ 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;
+ tclScaleTimeProcPtr(&vTime, tclTimeClientData);
+ 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;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 never exits. It dies with the overall
+ * process.
+ *
+ * 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;
+ int fds[2], receivePipe;
+ 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");
+ }
+
+ 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];
+
+ /*
+ * 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);
+
+ if (select(numFdBits, &readableMask, &writableMask, &exceptionMask,
+ timePtr) == -1) {
+ /*
+ * Try again immediately on an 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 ((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;
+ pthread_cond_broadcast(&notifierCV);
+ pthread_mutex_unlock(&notifierMutex);
+
+ TclpThreadExit(0);
+}
+#endif /* TCL_THREADS */
+
+#endif /* (!NOTIFIER_EPOLL && !NOTIFIER_KQUEUE) || !TCL_THREADS */
+#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 fc01616..f670349 100644
--- a/unix/tclUnixChan.c
+++ b/unix/tclUnixChan.c
@@ -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,
+#endif
+static int FileTruncateProc(void *instanceData,
Tcl_WideInt length);
-static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
+static Tcl_WideInt FileWideSeekProc(void *instanceData,
Tcl_WideInt offset, int mode, int *errorCode);
-static void FileWatchProc(ClientData instanceData, int mask);
+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? */
@@ -281,12 +310,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;
@@ -311,10 +340,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.
@@ -327,12 +357,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);
/*
@@ -348,17 +383,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 */
/*
*----------------------------------------------------------------------
@@ -378,16 +446,16 @@ 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;
+ FileState *fsPtr = (FileState *)instanceData;
Tcl_WideInt oldLoc, newLoc;
/*
@@ -395,7 +463,7 @@ FileSeekProc(
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
- if (oldLoc == Tcl_LongAsWide(-1)) {
+ if (oldLoc == -1) {
/*
* Bad things are happening. Error out...
*/
@@ -410,15 +478,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
/*
*----------------------------------------------------------------------
@@ -442,13 +511,13 @@ FileSeekProc(
static Tcl_WideInt
FileWideSeekProc(
- ClientData instanceData, /* File state. */
+ void *instanceData, /* File state. */
Tcl_WideInt 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;
+ FileState *fsPtr = (FileState *)instanceData;
Tcl_WideInt newLoc;
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
@@ -476,12 +545,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
@@ -518,11 +587,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);
@@ -585,12 +654,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;
@@ -613,11 +682,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
*/
@@ -627,7 +695,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);
@@ -658,7 +726,7 @@ TtySetOptionProc(
}
return TCL_ERROR;
}
- tcsetattr(fsPtr->fd, TCSADRAIN, &iostate);
+ tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
@@ -667,34 +735,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;
}
@@ -705,19 +781,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;
@@ -737,7 +814,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);
@@ -758,9 +835,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");
@@ -780,7 +857,7 @@ TtySetOptionProc(
}
} /* -ttycontrol options loop */
- ioctl(fsPtr->fd, TIOCMSET, &control);
+ ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
ckfree(argv);
return TCL_OK;
#else /* TIOCMGET&TIOCMSET */
@@ -788,8 +865,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");
}
/*
@@ -812,21 +993,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");
}
@@ -834,7 +1073,7 @@ TtyGetOptionProc(
TtyAttrs tty;
valid = 1;
- TtyGetAttributes(fsPtr->fd, &tty);
+ TtyGetAttributes(fsPtr->fileState.fd, &tty);
sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
Tcl_DStringAppendElement(dsPtr, buf);
}
@@ -848,11 +1087,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);
@@ -877,10 +1115,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);
sprintf(buf, "%d", inBuffered+inQueue);
Tcl_DStringAppendElement(dsPtr, buf);
@@ -894,24 +1132,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;
+ }
+ sprintf(buf, "%d", ws.ws_col);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ sprintf(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},
@@ -1035,7 +1298,7 @@ static const struct {int baud; speed_t speed;} speeds[] = {
#endif
{-1, 0}
};
-
+
/*
*---------------------------------------------------------------------------
*
@@ -1327,7 +1590,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);
@@ -1337,8 +1601,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;
@@ -1380,7 +1643,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;
@@ -1404,7 +1667,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 \"",
@@ -1436,8 +1699,6 @@ TclpOpenFileChannel(
fcntl(fd, F_SETFD, FD_CLOEXEC);
- sprintf(channelName, "file%d", fd);
-
#ifdef SUPPORTS_TTY
if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
/*
@@ -1457,18 +1718,27 @@ TclpOpenFileChannel(
translation = "auto crlf";
channelTypePtr = &ttyChannelType;
TtyInit(fd);
+ sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
+ sprintf(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) {
@@ -1480,14 +1750,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;
}
/*
@@ -1508,11 +1778,11 @@ TclpOpenFileChannel(
Tcl_Channel
Tcl_MakeFileChannel(
- ClientData handle, /* OS level handle. */
+ void *handle, /* OS level handle. */
int mode) /* ORed 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;
@@ -1531,22 +1801,30 @@ Tcl_MakeFileChannel(
sprintf(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;
sprintf(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;
}
/*
@@ -1664,17 +1942,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);
@@ -1738,166 +2015,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 */
-
/*
*----------------------------------------------------------------------
*
@@ -1919,10 +2036,10 @@ TclUnixWaitForFile(
static int
FileTruncateProc(
- ClientData instanceData,
+ void *instanceData,
Tcl_WideInt 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 2a68f7f..7717721 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -47,9 +47,9 @@
* library calls.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
-typedef struct ThreadSpecificData {
+typedef struct {
struct passwd pwd;
#if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5)
#define NEED_PW_CLEANER 1
@@ -118,10 +118,10 @@ static int CopyString(const char *src, char *buf, int buflen);
#endif
#ifdef NEED_PW_CLEANER
-static void FreePwBuf(ClientData ignored);
+static void FreePwBuf(ClientData dummy);
#endif
#ifdef NEED_GR_CLEANER
-static void FreeGrBuf(ClientData ignored);
+static void FreeGrBuf(ClientData dummy);
#endif
#endif /* TCL_THREADS */
@@ -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);
@@ -201,7 +201,7 @@ TclpGetPwNam(
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
- tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen);
+ tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
@@ -214,7 +214,7 @@ TclpGetPwNam(
return NULL;
}
tsdPtr->pbuflen *= 2;
- tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
+ tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
@@ -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);
@@ -281,7 +281,7 @@ TclpGetPwUid(
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
- tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen);
+ tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
@@ -294,7 +294,7 @@ TclpGetPwUid(
return NULL;
}
tsdPtr->pbuflen *= 2;
- tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
+ tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
@@ -336,7 +336,7 @@ TclpGetPwUid(
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
- ClientData ignored)
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -365,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);
@@ -384,7 +384,7 @@ TclpGetGrNam(
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
- tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen);
+ tsdPtr->gbuf = (char*)ckalloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
@@ -397,7 +397,7 @@ TclpGetGrNam(
return NULL;
}
tsdPtr->gbuflen *= 2;
- tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
+ tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
@@ -445,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);
@@ -464,7 +464,7 @@ TclpGetGrGid(
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
- tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen);
+ tsdPtr->gbuf = (char*)ckalloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
@@ -477,7 +477,7 @@ TclpGetGrGid(
return NULL;
}
tsdPtr->gbuflen *= 2;
- tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
+ tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
@@ -519,7 +519,7 @@ TclpGetGrGid(
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
- ClientData ignored)
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -548,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);
@@ -618,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);
@@ -685,8 +685,8 @@ CopyGrp(
char *buf,
int buflen)
{
- register char *p = buf;
- register int copied, len = 0;
+ char *p = buf;
+ int copied, len = 0;
/*
* Copy username.
@@ -887,7 +887,7 @@ CopyArray(
int buflen) /* Size of buffer. */
{
int i, j, len = 0;
- char *p, **new;
+ char *p, **newBuffer;
if (src == NULL) {
return 0;
@@ -903,7 +903,7 @@ CopyArray(
return -1;
}
- new = (char **) buf;
+ newBuffer = (char **) buf;
p = buf + len;
for (j = 0; j < i; j++) {
@@ -914,10 +914,10 @@ CopyArray(
return -1;
}
memcpy(p, src[j], sz);
- new[j] = p;
+ newBuffer[j] = p;
p = buf + len;
}
- new[j] = NULL;
+ newBuffer[j] = NULL;
return len;
}
@@ -988,8 +988,8 @@ 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;
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index 9abd70a..b188f21 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -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
@@ -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. */
@@ -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,7 +1363,7 @@ GetGroupAttribute(
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
- *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
+ *attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_gid);
} else {
Tcl_DString ds;
const char *utf;
@@ -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,7 +1417,7 @@ GetOwnerAttribute(
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
- *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
+ *attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_uid);
} else {
Tcl_DString ds;
@@ -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. */
{
@@ -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(), -1); /* 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;
}
@@ -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(), -1); /* 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 TclDStringToObj(&tmp);
+}
+
#if defined(__CYGWIN__)
static void
@@ -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;
}
- *attributePtrPtr = Tcl_NewIntObj((fileAttributes&attributeArray[objIndex])!=0);
-
+ *attributePtrPtr = Tcl_NewWideIntObj(
+ (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);
-
+ *attributePtrPtr = Tcl_NewWideIntObj((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 f70ce6a..fdf7904 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -34,16 +34,16 @@ 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*/)
{
Tcl_Encoding encoding;
-#ifdef __CYGWIN__
int length;
- char buf[PATH_MAX * 2];
- char name[PATH_MAX * TCL_UTF_MAX + 1];
+ wchar_t buf[PATH_MAX];
+ char name[PATH_MAX * 3 + 1];
+
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
@@ -54,7 +54,14 @@ TclpFindExecutable(
encoding = Tcl_GetEncoding(NULL, NULL);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), encoding);
+}
#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;
Tcl_DString buffer, nameString, cwd, utfName;
@@ -192,8 +199,8 @@ TclpFindExecutable(
done:
Tcl_DStringFree(&buffer);
-#endif
}
+#endif
/*
*----------------------------------------------------------------------
@@ -249,9 +256,9 @@ TclpMatchInDirectory(
Tcl_Obj *tailPtr;
const char *nativeTail;
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const char *)Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
- nativeTail = Tcl_FSGetNativePath(tailPtr);
+ nativeTail = (const char *)Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
@@ -262,14 +269,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);
/*
@@ -554,6 +562,8 @@ NativeMatchType(
return matchResult;
}
}
+#else
+ (void)interp;
#endif /* MAC_OSX_TCL */
return 1;
@@ -621,7 +631,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;
@@ -649,7 +659,7 @@ int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory */
{
- const char *path = Tcl_FSGetNativePath(pathPtr);
+ const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
@@ -678,7 +688,7 @@ TclpObjLstat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
- return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
+ return TclOSlstat((const char *)Tcl_FSGetNativePath(pathPtr), bufPtr);
}
/*
@@ -719,7 +729,7 @@ TclpGetNativeCwd(
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
- char *newCd = ckalloc(strlen(buffer) + 1);
+ char *newCd = (char*)ckalloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
return newCd;
@@ -846,7 +856,7 @@ TclpObjStat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
- const char *path = Tcl_FSGetNativePath(pathPtr);
+ const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
@@ -863,7 +873,7 @@ TclpObjLink(
int linkAction)
{
if (toPtr != NULL) {
- const char *src = Tcl_FSGetNativePath(pathPtr);
+ const char *src = (const char *)Tcl_FSGetNativePath(pathPtr);
const char *target = NULL;
if (src == NULL) {
@@ -909,7 +919,7 @@ TclpObjLink(
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
- target = Tcl_FSGetNativePath(toPtr);
+ target = (const char*)Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
@@ -937,7 +947,6 @@ TclpObjLink(
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
- int targetLen;
Tcl_DString ds;
Tcl_Obj *transPtr;
@@ -951,8 +960,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) {
@@ -982,7 +991,7 @@ TclpObjLink(
}
Tcl_DecrRefCount(transPtr);
- length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
+ length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
@@ -1016,7 +1025,7 @@ TclpObjLink(
Tcl_Obj *
TclpFilesystemPathType(
- Tcl_Obj *pathPtr)
+ TCL_UNUSED(Tcl_Obj *))
{
/*
* All native paths are of the same type.
@@ -1080,7 +1089,7 @@ TclNativeCreateNativeRep(
const char *str;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
- int len;
+ size_t len;
if (TclFSCwdIsNative()) {
/*
@@ -1105,7 +1114,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)) {
@@ -1115,8 +1125,8 @@ TclNativeCreateNativeRep(
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
- nativePathPtr = ckalloc(len);
- memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);
+ nativePathPtr = (char *)ckalloc(len);
+ memcpy(nativePathPtr, Tcl_DStringValue(&ds), len);
Tcl_DStringFree(&ds);
return nativePathPtr;
@@ -1156,7 +1166,7 @@ TclNativeDupInternalRep(
len = (strlen((const char*) clientData) + 1) * sizeof(char);
- copy = ckalloc(len);
+ copy = (char *)ckalloc(len);
memcpy(copy, clientData, len);
return copy;
}
@@ -1182,7 +1192,7 @@ TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
- return utime(Tcl_FSGetNativePath(pathPtr), tval);
+ return utime((const char *)Tcl_FSGetNativePath(pathPtr), tval);
}
#ifdef __CYGWIN__
@@ -1193,7 +1203,7 @@ TclOSstat(
void *cygstat)
{
struct stat buf;
- Tcl_StatBuf *statBuf = cygstat;
+ Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
int result = stat(name, &buf);
statBuf->st_mode = buf.st_mode;
@@ -1216,7 +1226,7 @@ TclOSlstat(
void *cygstat)
{
struct stat buf;
- Tcl_StatBuf *statBuf = cygstat;
+ Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
int result = lstat(name, &buf);
statBuf->st_mode = buf.st_mode;
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index b189fee..f5d8fee 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -9,8 +9,6 @@
*/
#include "tclInt.h"
-#include <stddef.h>
-#include <locale.h>
#ifdef HAVE_LANGINFO
# include <langinfo.h>
# ifdef __APPLE__
@@ -33,11 +31,20 @@
#endif
#ifdef __CYGWIN__
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef __clang__
+#pragma clang diagnostic ignored "-Wignored-attributes"
+#endif
DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *);
DLLIMPORT extern __stdcall void FreeLibrary(void *);
DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
DLLIMPORT extern __stdcall void GetSystemInfo(void *);
+#ifdef __cplusplus
+}
+#endif
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
@@ -110,7 +117,7 @@ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH;
* first list checked for a mapping from env encoding to Tcl encoding name.
*/
-typedef struct LocaleTable {
+typedef struct {
const char *lang;
const char *encoding;
} LocaleTable;
@@ -316,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)\
)))
@@ -386,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
@@ -419,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.
*/
@@ -456,7 +455,7 @@ TclpInitPlatform(void)
void
TclpInitLibraryPath(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
@@ -545,9 +544,10 @@ TclpInitLibraryPath(
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
- str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
- *valuePtr = (char *)ckalloc((*lengthPtr) + 1);
- memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1);
+ str = TclGetString(pathPtr);
+ *lengthPtr = pathPtr->length;
+ *valuePtr = (char *)ckalloc(*lengthPtr + 1);
+ memcpy(*valuePtr, str, *lengthPtr + 1);
Tcl_DecrRefCount(pathPtr);
}
@@ -764,7 +764,7 @@ InitMacLocaleInfoVar(
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
- Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "::tcl::mac::locale", NULL, loc, TCL_GLOBAL_ONLY);
}
CFRelease(localeRef);
}
@@ -800,9 +800,9 @@ TclpSetVariables(
const char *str;
CFBundleRef bundleRef;
- Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ Tcl_SetVar2(interp, "tclDefaultLibrary", NULL, tclLibPath, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, tclLibPath, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
@@ -818,9 +818,9 @@ TclpSetVariables(
*p = ' ';
}
} while (*p++);
- Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
- Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_DStringFree(&ds);
}
@@ -835,9 +835,9 @@ TclpSetVariables(
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
- Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
- Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
@@ -848,20 +848,20 @@ TclpSetVariables(
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
- Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
- Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
}
- Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
- Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
@@ -1009,7 +1009,7 @@ TclpFindVariable(
* searches). */
{
int i, result = -1;
- register const char *env, *p1, *p2;
+ const char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
@@ -1054,22 +1054,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 0a5712a..6b1ec3d 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -1,276 +1,41 @@
-#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.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright (c) 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 <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.
@@ -306,165 +71,7 @@ StartNotifierThread(const char *proc)
pthread_mutex_unlock(&notifierInitMutex);
}
}
-#endif /* TCL_THREADS */
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_InitNotifier --
- *
- * Initializes the platform specific notifier state.
- *
- * Results:
- * Returns a handle to the notifier state for this thread.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void *
-Tcl_InitNotifier(void)
-{
- 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;
-
- 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;
-
- 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
- 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);
-
-#endif /* TCL_THREADS */
- return tsdPtr;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FinalizeNotifier --
- *
- * 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
-Tcl_FinalizeNotifier(
- void *clientData)
-{
- 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.
- */
-
- 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;
- }
- }
-
- /*
- * 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 */
- }
-}
+#endif /* NOTIFIER_SELECT */
/*
*----------------------------------------------------------------------
@@ -480,20 +87,27 @@ Tcl_FinalizeNotifier(
* None.
*
* Side effects:
- * Signals the notifier condition variable for the specified notifier.
+ * 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_AlertNotifier(
- void *clientData)
+ ClientData clientData)
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
-#ifdef TCL_THREADS
+#ifdef NOTIFIER_SELECT
+#if TCL_THREADS
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
pthread_mutex_lock(&notifierMutex);
@@ -506,6 +120,22 @@ Tcl_AlertNotifier(
# endif /* __CYGWIN__ */
pthread_mutex_unlock(&notifierMutex);
#endif /* TCL_THREADS */
+#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 */
}
}
@@ -568,173 +198,11 @@ Tcl_ServiceModeHook(
tclNotifierHooks.serviceModeHookProc(mode);
return;
} else 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,594 +280,62 @@ 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__ */
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_WaitForEvent --
- *
- * 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
-Tcl_WaitForEvent(
- const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
-{
- 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 */
-
- /*
- * 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;
- 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;
- } else {
- timeoutPtr = NULL;
-#endif /* !TCL_THREADS */
- }
-
-#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 (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;
- }
-#ifdef TCL_THREADS
- pthread_mutex_unlock(&notifierMutex);
-#endif /* TCL_THREADS */
- return 0;
- }
-}
-
-#ifdef TCL_THREADS
+#ifdef NOTIFIER_SELECT
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
- * NotifierThreadProc --
+ * AlertSingleThread --
*
- * 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.
+ * 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.
*
* Result:
- * None. Once started, this routine never exits. It dies with the overall
- * process.
+ * None.
*
* Side effects:
- * The trigger pipe used to signal the notifier thread is created when
- * the notifier thread first starts.
+ * The condition variable associated with the thread is broadcasted.
*
*----------------------------------------------------------------------
*/
static void
-NotifierThreadProc(
- void *dummy) /* Not used. */
+AlertSingleThread(
+ ThreadSpecificData *tsdPtr)
{
- 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");
+ tsdPtr->eventReady = 1;
+ if (tsdPtr->onList) {
+ /*
+ * 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 (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;
}
-
- /*
- * 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);
-
- /*
- * 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 select mask to include the receive pipe.
- */
-
- if (receivePipe >= numFdBits) {
- numFdBits = receivePipe + 1;
- }
- FD_SET(receivePipe, &readableMask);
-
- if (select(numFdBits, &readableMask, &writableMask, &exceptionMask,
- timePtr) == -1) {
- /*
- * Try again immediately on an 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)) {
- 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;
- }
#ifdef __CYGWIN__
- PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
-#else /* __CYGWIN__ */
- pthread_cond_broadcast(&tsdPtr->waitCV);
+ PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
+#else /* !__CYGWIN__ */
+ pthread_cond_broadcast(&tsdPtr->waitCV);
#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.
- */
-
- 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;
- 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);
-#endif
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AtForkParent --
- *
- * Unlock the notifier in the parent after a fork.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AtForkParent(void)
-{
-#if RESET_ATFORK_MUTEX == 0
- pthread_mutex_unlock(&notifierInitMutex);
-#endif
-}
-
-/*
- *----------------------------------------------------------------------
- *
* AtForkChild --
*
* Unlock and reinstall the notifier in the child after a fork.
@@ -1419,18 +355,15 @@ AtForkChild(void)
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);
/*
- * notifierThreadRunning == 1: thread is running, (there might be data in notifier lists)
+ * notifierThreadRunning == 1: thread is running, (there might be data in
+ * notifier lists)
* atForkInit == 0: InitNotifier was never called
- * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
+ * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
* waitingListPtr != 0: there are threads currently waiting for events.
*/
@@ -1451,19 +384,20 @@ AtForkChild(void)
waitingListPtr = NULL;
/*
- * The tsdPtr from before the fork is copied as well. But since
- * we are paranoic, we don't trust its condvar and reset it.
+ * The tsdPtr from before the fork is copied as well. But since we
+ * are paranoic, 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,
+ tsdPtr->hwnd = CreateWindowExW(NULL, className,
+ className, 0, 0, 0, 0, 0, NULL, NULL,
TclWinGetTclInstance(), NULL);
ResetEvent(tsdPtr->event);
-#else
+#else /* !__CYGWIN__ */
pthread_cond_destroy(&tsdPtr->waitCV);
pthread_cond_init(&tsdPtr->waitCV, NULL);
-#endif
+#endif /* __CYGWIN__ */
+
/*
* In case, we had multiple threads running before the fork,
* make sure, we don't try to reach out to their thread local data.
@@ -1483,8 +417,155 @@ AtForkChild(void)
#endif /* TCL_THREADS */
-#endif /* !HAVE_COREFOUNDATION */
+#endif /* NOTIFIER_SELECT */
+#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;
+ struct pollfd pollFds[1];
+ int numFound, result = 0, pollTimeout;
+
+ /*
+ * 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;
+ }
+
+ /*
+ * Setup the pollfd structure for the fd.
+ */
+
+ 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;
+ }
+
+ /*
+ * Loop in a mini-event loop of our own, waiting for either the file to
+ * become ready or a timeout to occur.
+ */
+
+ 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;
+ }
+ }
+
+ /*
+ * Wait for the event or a timeout.
+ */
+
+ 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 */
+
/*
* Local Variables:
* mode: c
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index b98ea26..681ee64 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -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;
@@ -268,7 +268,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();
@@ -431,8 +431,8 @@ 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]);
@@ -743,7 +743,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;
@@ -809,7 +809,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];
@@ -868,10 +868,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]);
}
@@ -901,12 +901,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) {
@@ -941,11 +941,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;
@@ -1036,13 +1036,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? */
@@ -1087,12 +1087,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;
@@ -1132,12 +1132,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) {
@@ -1180,11 +1180,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));
@@ -1249,7 +1249,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. */
@@ -1265,7 +1265,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.
@@ -1283,11 +1283,11 @@ Tcl_PidObjCmd(
* Extract the process IDs from the pipe structure.
*/
- pipePtr = Tcl_GetChannelInstanceData(chan);
+ pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
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 0ae4f25..bb944e4 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -86,6 +86,9 @@ typedef off_t Tcl_SeekOffset;
#endif
#ifdef __CYGWIN__
+#ifdef __cplusplus
+extern "C" {
+#endif
/* Make some symbols available without including <windows.h> */
# define DWORD unsigned int
# define CP_UTF8 65001
@@ -95,8 +98,12 @@ typedef off_t Tcl_SeekOffset;
# define SOCKET unsigned int
# define WSAEWOULDBLOCK 10035
typedef unsigned short WCHAR;
- __declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *);
- __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int);
+#ifdef __clang__
+#pragma clang diagnostic push
+#pragma clang diagnostic ignored "-Wignored-attributes"
+#endif
+ __declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const void *, void *);
+ __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const void *, int);
__declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int,
char *, int, const char *, void *);
__declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
@@ -107,9 +114,15 @@ typedef off_t Tcl_SeekOffset;
__declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
__declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);
__declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
+#ifdef __clang__
+#pragma clang diagnostic pop
+#endif
# define timezone _timezone
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 TclOSstat(name, buf) stat64(name, (struct stat64 *)buf)
# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf)
@@ -148,14 +161,12 @@ typedef off_t Tcl_SeekOffset;
#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>
@@ -185,13 +196,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
@@ -612,10 +617,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 */
@@ -688,7 +691,7 @@ typedef int socklen_t;
#define TclpExit exit
-#ifdef TCL_THREADS
+#if !defined(TCL_THREADS) || TCL_THREADS
# include <pthread.h>
#endif /* TCL_THREADS */
@@ -708,14 +711,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 ddba078..cb20166 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -53,6 +53,8 @@ typedef struct TcpFdList {
struct TcpState {
Tcl_Channel channel; /* Channel associated with this file. */
+ int testFlags; /* bit field for tests. Is set by testsocket
+ * test procedure */
TcpFdList fds; /* The file descriptors of the sockets. */
int flags; /* ORed combination of the bitfields defined
* below. */
@@ -64,7 +66,7 @@ struct TcpState {
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
- ClientData acceptProcData; /* The data for the accept proc. */
+ void *acceptProcData; /* The data for the accept proc. */
/*
* Only needed for client sockets
@@ -94,6 +96,15 @@ struct TcpState {
#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */
/*
+ * These bits may be ORed together into the "testFlags" field of a TcpState
+ * structure.
+ */
+
+#define TCP_ASYNC_TEST_MODE (1<<0) /* Async testing activated. Do not
+ * automatically continue connection
+ * process. */
+
+/*
* The following defines the maximum length of the listen queue. This is the
* number of outstanding yet-to-be-serviced requests for a connection on a
* server socket, more than this number of outstanding requests and the
@@ -118,27 +129,27 @@ struct TcpState {
* Static routines for this file:
*/
-static void TcpAsyncCallback(ClientData clientData, int mask);
+static void TcpAsyncCallback(void *clientData, int mask);
static int TcpConnect(Tcl_Interp *interp, TcpState *state);
-static void TcpAccept(ClientData data, int mask);
-static int TcpBlockModeProc(ClientData data, int mode);
-static int TcpCloseProc(ClientData instanceData,
+static void TcpAccept(void *data, int mask);
+static int TcpBlockModeProc(void *data, int mode);
+static int TcpCloseProc(void *instanceData,
Tcl_Interp *interp);
-static int TcpClose2Proc(ClientData instanceData,
+static int TcpClose2Proc(void *instanceData,
Tcl_Interp *interp, int flags);
-static int TcpGetHandleProc(ClientData instanceData,
- int direction, ClientData *handlePtr);
-static int TcpGetOptionProc(ClientData instanceData,
+static int TcpGetHandleProc(void *instanceData,
+ int direction, void **handlePtr);
+static int TcpGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
-static int TcpInputProc(ClientData instanceData, char *buf,
+static int TcpInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
-static int TcpOutputProc(ClientData instanceData,
+static int TcpOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
-static void TcpThreadActionProc(ClientData instanceData, int action);
-static void TcpWatchProc(ClientData instanceData, int mask);
+static void TcpThreadActionProc(void *instanceData, int action);
+static void TcpWatchProc(void *instanceData, int mask);
static int WaitForConnect(TcpState *statePtr, int *errorCodePtr);
-static void WrapNotify(ClientData clientData, int mask);
+static void WrapNotify(void *clientData, int mask);
/*
* This structure describes the channel type structure for TCP socket
@@ -148,7 +159,11 @@ static void WrapNotify(ClientData 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. */
@@ -208,7 +223,7 @@ printaddrinfo(
static void
InitializeHostName(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *native = NULL;
@@ -244,9 +259,6 @@ InitializeHostName(
native = u.nodename;
}
}
- if (native == NULL) {
- native = tclEmptyStringRep;
- }
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
@@ -275,9 +287,15 @@ InitializeHostName(
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
- *lengthPtr = strlen(native);
- *valuePtr = ckalloc(*lengthPtr + 1);
- memcpy(*valuePtr, native, (size_t)(*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';
+ }
}
/*
@@ -322,10 +340,8 @@ Tcl_GetHostName(void)
int
TclpHasSockets(
- Tcl_Interp *dummy) /* Not used. */
+ TCL_UNUSED(Tcl_Interp *))
{
- (void)dummy;
-
return TCL_OK;
}
@@ -370,7 +386,7 @@ TclpFinalizeSockets(void)
static int
TcpBlockModeProc(
- ClientData instanceData, /* Socket state. */
+ void *instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
@@ -448,6 +464,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->testFlags, 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 {
@@ -501,7 +531,7 @@ WaitForConnect(
static int
TcpInputProc(
- ClientData instanceData, /* Socket state. */
+ void *instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
@@ -552,7 +582,7 @@ TcpInputProc(
static int
TcpOutputProc(
- ClientData instanceData, /* Socket state. */
+ void *instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
@@ -593,13 +623,12 @@ TcpOutputProc(
static int
TcpCloseProc(
- ClientData instanceData, /* The socket to close. */
- Tcl_Interp *dummy) /* For error reporting - unused. */
+ void *instanceData, /* The socket to close. */
+ 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
@@ -655,14 +684,13 @@ TcpCloseProc(
static int
TcpClose2Proc(
- ClientData instanceData, /* The socket to close. */
- Tcl_Interp *dummy, /* For error reporting. */
+ void *instanceData, /* The socket to close. */
+ 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.
@@ -807,7 +835,7 @@ TcpHostPortList(
static int
TcpGetOptionProc(
- ClientData 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
@@ -973,7 +1001,7 @@ TcpGetOptionProc(
static void
TcpThreadActionProc(
- ClientData instanceData,
+ void *instanceData,
int action)
{
TcpState *statePtr = (TcpState *)instanceData;
@@ -1018,7 +1046,7 @@ TcpThreadActionProc(
static void
WrapNotify(
- ClientData clientData,
+ void *clientData,
int mask)
{
TcpState *statePtr = (TcpState *) clientData;
@@ -1047,7 +1075,7 @@ WrapNotify(
static void
TcpWatchProc(
- ClientData instanceData, /* The socket state. */
+ void *instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
@@ -1120,12 +1148,11 @@ TcpWatchProc(
static int
TcpGetHandleProc(
- ClientData instanceData, /* The socket state. */
- int direction, /* Not used. */
- ClientData *handlePtr) /* Where to store the handle. */
+ void *instanceData, /* The socket state. */
+ 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;
@@ -1145,13 +1172,9 @@ TcpGetHandleProc(
static void
TcpAsyncCallback(
- ClientData clientData, /* The socket state. */
- int mask) /* Events of interest; an OR-ed combination of
- * TCL_READABLE, TCL_WRITABLE and
- * TCL_EXCEPTION. */
+ void *clientData, /* The socket state. */
+ TCL_UNUSED(int) /*mask*/)
{
- (void)mask;
-
TcpConnect(NULL, (TcpState *)clientData);
}
@@ -1194,6 +1217,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 +1228,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
@@ -1458,7 +1481,7 @@ Tcl_OpenTcpClient(
Tcl_Channel
Tcl_MakeTcpClientChannel(
- ClientData sock) /* The socket to wrap up into a channel. */
+ void *sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
TCL_READABLE | TCL_WRITABLE);
@@ -1510,7 +1533,7 @@ TclpMakeTcpClientChannelMode(
/*
*----------------------------------------------------------------------
*
- * Tcl_OpenTcpServer --
+ * Tcl_OpenTcpServerEx --
*
* Opens a TCP server socket and creates a channel around it.
*
@@ -1525,16 +1548,17 @@ 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. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
- ClientData acceptProcData) /* Data for the callback. */
+ 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 +1573,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 +1641,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 +1700,9 @@ Tcl_OpenTcpServer(
}
close(sock);
sock = -1;
+ if (port == 0 && errno == EADDRINUSE) {
+ goto repeat;
+ }
continue;
}
if (port == 0 && chosenport == 0) {
@@ -1643,6 +1726,9 @@ Tcl_OpenTcpServer(
}
close(sock);
sock = -1;
+ if (port == 0 && errno == EADDRINUSE) {
+ goto repeat;
+ }
continue;
}
if (statePtr == NULL) {
@@ -1717,8 +1803,8 @@ Tcl_OpenTcpServer(
static void
TcpAccept(
- ClientData data, /* Callback token. */
- int mask) /* Not used. */
+ void *data, /* Callback token. */
+ TCL_UNUSED(int) /*mask*/)
{
TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */
int newsock; /* The new client socket */
@@ -1727,7 +1813,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);
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index c5ac52a..b06abdf0 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -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;
}
sprintf(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 ef8e737..795c62c 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -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)
+ *
+ *----------------------------------------------------------------------
+ */
-typedef struct ThreadSpecificData {
+#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 */
+
+/*
+ * 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 */
/*
* masterLock 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 dyamically 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 MASTER_LOCK pthread_mutex_lock(&masterLock)
-#define MASTER_UNLOCK pthread_mutex_unlock(&masterLock)
+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;
@@ -114,17 +261,17 @@ TclpThreadCreate(
}
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
- if (! (flags & TCL_THREAD_JOINABLE)) {
- pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED);
+ if (!(flags & TCL_THREAD_JOINABLE)) {
+ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
- (void * (*)(void *))(void *)proc, (void *)clientData) &&
+ (void * (*)(void *))(void *)proc, (void *) clientData) &&
pthread_create(&theThread, NULL,
- (void * (*)(void *))(void *)proc, (void *)clientData)) {
+ (void * (*)(void *))(void *)proc, (void *) clientData)) {
result = TCL_ERROR;
} else {
- *idPtr = (Tcl_ThreadId)theThread;
+ *idPtr = (Tcl_ThreadId) theThread;
result = TCL_OK;
}
pthread_attr_destroy(&attr);
@@ -157,7 +304,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;
@@ -171,7 +318,6 @@ Tcl_JoinThread(
#endif
}
-#ifdef TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -192,9 +338,12 @@ void
TclpThreadExit(
int status)
{
+#if TCL_THREADS
pthread_exit(INT2PTR(status));
-}
+#else /* TCL_THREADS */
+ exit(status);
#endif /* TCL_THREADS */
+}
/*
*----------------------------------------------------------------------
@@ -215,7 +364,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 +393,7 @@ Tcl_GetCurrentThread(void)
void
TclpInitLock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_lock(&initLock);
#endif
}
@@ -252,7 +401,7 @@ TclpInitLock(void)
/*
*----------------------------------------------------------------------
*
- * TclpFinalizeLock
+ * TclFinalizeLock
*
* This procedure is used to destroy all private resources used in this
* file.
@@ -270,7 +419,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 +450,7 @@ TclFinalizeLock(void)
void
TclpInitUnlock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_unlock(&initLock);
#endif
}
@@ -330,11 +479,10 @@ TclpInitUnlock(void)
void
TclpMasterLock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_lock(&masterLock);
#endif
}
-
/*
*----------------------------------------------------------------------
@@ -356,7 +504,7 @@ TclpMasterLock(void)
void
TclpMasterUnlock(void)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
pthread_mutex_unlock(&masterLock);
#endif
}
@@ -383,15 +531,17 @@ TclpMasterUnlock(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
/*
*----------------------------------------------------------------------
@@ -416,26 +566,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) {
- MASTER_LOCK;
+ pthread_mutex_lock(&masterLock);
if (*mutexPtr == NULL) {
/*
* Double inside master lock check to avoid a race condition.
*/
- pmutexPtr = 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);
}
- MASTER_UNLOCK;
+ pthread_mutex_unlock(&masterLock);
}
- pmutexPtr = *((pthread_mutex_t **)mutexPtr);
- pthread_mutex_lock(pmutexPtr);
+ pmutexPtr = *((PMutex **) mutexPtr);
+ PMutexLock(pmutexPtr);
}
/*
@@ -457,11 +607,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);
}
/*
@@ -487,10 +637,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;
}
@@ -521,15 +671,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) {
- MASTER_LOCK;
+ pthread_mutex_lock(&masterLock);
/*
* Double check inside mutex to avoid race, then initialize condition
@@ -537,17 +687,17 @@ Tcl_ConditionWait(
*/
if (*condPtr == NULL) {
- pcondPtr = ckalloc(sizeof(pthread_cond_t));
+ pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t));
pthread_cond_init(pcondPtr, NULL);
*condPtr = (Tcl_Condition) pcondPtr;
TclRememberCondition(condPtr);
}
- MASTER_UNLOCK;
+ pthread_mutex_unlock(&masterLock);
}
- pmutexPtr = *((pthread_mutex_t **)mutexPtr);
- pcondPtr = *((pthread_cond_t **)condPtr);
+ pmutexPtr = *((PMutex **) mutexPtr);
+ pcondPtr = *((pthread_cond_t **) condPtr);
if (timePtr == NULL) {
- pthread_cond_wait(pcondPtr, pmutexPtr);
+ PCondWait(pcondPtr, pmutexPtr);
} else {
Tcl_Time now;
@@ -560,7 +710,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);
}
}
@@ -587,12 +737,13 @@ void
Tcl_ConditionNotify(
Tcl_Condition *condPtr)
{
- pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr);
+ pthread_cond_t *pcondPtr = *((pthread_cond_t **) condPtr);
+
if (pcondPtr != NULL) {
pthread_cond_broadcast(pcondPtr);
} else {
/*
- * Noone has used the condition variable, so there are no waiters.
+ * No-one has used the condition variable, so there are no waiters.
*/
}
}
@@ -620,7 +771,7 @@ void
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
- pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
+ pthread_cond_t *pcondPtr = *(pthread_cond_t **) condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
@@ -651,6 +802,7 @@ TclpFinalizeCondition(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DirEntry *
TclpReaddir(
TclDIR * dir)
@@ -663,7 +815,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,34 +825,34 @@ 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 allocMutex {
+typedef struct {
Tcl_Mutex tlock;
- pthread_mutex_t plock;
-} allocMutex;
+ PMutex plock;
+} AllocMutex;
Tcl_Mutex *
TclpNewAllocMutex(void)
{
- struct allocMutex *lockPtr;
- register pthread_mutex_t *plockPtr;
+ AllocMutex *lockPtr;
+ PMutex *plockPtr;
- lockPtr = malloc(sizeof(struct allocMutex));
+ lockPtr = (AllocMutex *)malloc(sizeof(AllocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
plockPtr = &lockPtr->plock;
lockPtr->tlock = (Tcl_Mutex) plockPtr;
- pthread_mutex_init(&lockPtr->plock, NULL);
+ PMutexInit(&lockPtr->plock);
return &lockPtr->tlock;
}
@@ -708,15 +860,22 @@ void
TclpFreeAllocMutex(
Tcl_Mutex *mutex) /* The alloc mutex to free. */
{
- allocMutex* lockPtr = (allocMutex*) mutex;
+ AllocMutex *lockPtr = (AllocMutex *) mutex;
+
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)
{
@@ -729,28 +888,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);
}
@@ -767,7 +917,7 @@ TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
- ptkeyPtr = TclpSysAlloc(sizeof *ptkeyPtr, 0);
+ ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t), 0);
if (NULL == ptkeyPtr) {
Tcl_Panic("unable to allocate thread key!");
}
@@ -783,7 +933,7 @@ void
TclpThreadDeleteKey(
void *keyPtr)
{
- pthread_key_t *ptkeyPtr = keyPtr;
+ pthread_key_t *ptkeyPtr = (pthread_key_t *)keyPtr;
if (pthread_key_delete(*ptkeyPtr)) {
Tcl_Panic("unable to delete key!");
@@ -797,7 +947,7 @@ TclpThreadSetMasterTSD(
void *tsdKeyPtr,
void *ptr)
{
- pthread_key_t *ptkeyPtr = tsdKeyPtr;
+ pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr;
if (pthread_setspecific(*ptkeyPtr, ptr)) {
Tcl_Panic("unable to set master TSD value");
@@ -808,7 +958,7 @@ void *
TclpThreadGetMasterTSD(
void *tsdKeyPtr)
{
- pthread_key_t *ptkeyPtr = tsdKeyPtr;
+ pthread_key_t *ptkeyPtr = (pthread_key_t*)tsdKeyPtr;
return pthread_getspecific(*ptkeyPtr);
}
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 0fc87ea..07b3065 100644
--- a/unix/tclUnixTime.c
+++ b/unix/tclUnixTime.c
@@ -11,7 +11,6 @@
*/
#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,7 @@ static void NativeGetTime(Tcl_Time *timebuf,
Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
-ClientData tclTimeClientData = NULL;
+void *tclTimeClientData = NULL;
/*
*----------------------------------------------------------------------
@@ -334,6 +336,7 @@ Tcl_GetTime(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGetDate(
const time_t *time,
@@ -423,6 +426,7 @@ TclpLocaltime(
return &tsdPtr->localtime_buf;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -504,8 +508,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 +534,7 @@ NativeScaleTime(
static void
NativeGetTime(
Tcl_Time *timePtr,
- ClientData clientData)
+ TCL_UNUSED(ClientData))
{
struct timeval tv;
@@ -557,6 +561,7 @@ NativeGetTime(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static void
SetTZIfNecessary(void)
{
@@ -573,7 +578,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 +603,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 a5d92d6..cf99fb2 100644
--- a/unix/tclXtNotify.c
+++ b/unix/tclXtNotify.c
@@ -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
@@ -232,7 +232,7 @@ InitNotifier(void)
static void
NotifierExitHandler(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
@@ -305,7 +305,7 @@ SetTimer(
static void
TimerProc(
- XtPointer clientData, /* Not used. */
+ TCL_UNUSED(XtPointer),
XtIntervalId *id)
{
if (*id != notifier.currentTimeout) {
@@ -359,7 +359,7 @@ CreateFileHandler(
}
}
if (filePtr == NULL) {
- filePtr = ckalloc(sizeof(FileHandler));
+ filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->read = 0;
filePtr->write = 0;
@@ -525,7 +525,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 f7c2652..6c09a50 100644
--- a/unix/tclXtTest.c
+++ b/unix/tclXtTest.c
@@ -48,7 +48,7 @@ int
Tclxttest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
XtToolkitInitialize();
@@ -78,7 +78,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..4c2068c 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.2.0
diff --git a/win/Makefile.in b/win/Makefile.in
index 651f6b2..344db71 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -102,11 +102,12 @@ SRC_DIR = @srcdir@
ROOT_DIR = @srcdir@/..
TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P)
GENERIC_DIR = $(TOP_DIR)/generic
-TOMMATH_DIR = $(TOP_DIR)/libtommath
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.
CYGPATH = @CYGPATH@
@@ -117,7 +118,6 @@ includedir_native = $(shell $(CYGPATH) '$(includedir)')
mandir_native = $(shell $(CYGPATH) '$(mandir)')
TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)')
GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)')
-TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)')
WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)')
ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
SCRIPT_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(SCRIPT_INSTALL_DIR)')
@@ -125,10 +125,8 @@ 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)')
-#GENERIC_DIR_NATIVE = $(GENERIC_DIR)
-#TOMMATH_DIR_NATIVE = $(TOMMATH_DIR)
-#WIN_DIR_NATIVE = $(WIN_DIR)
-#ROOT_DIR_NATIVE = $(ROOT_DIR)
+MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)')
+TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)')
# Fully qualify library path so that `make test`
# does not depend on the current directory.
@@ -145,6 +143,11 @@ 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@
@@ -155,16 +158,19 @@ REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
-TEST_LOAD_PRMS = package ifneeded dde 1.4.3 [list load [file normalize ${DDE_DLL_FILE}] dde];\
+TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
+ package ifneeded dde 1.4.3 [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}] 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)
@@ -180,7 +186,7 @@ TCL_EXE = @TCL_EXE@
# Setting the VPATH variable to a list of paths will cause the Makefile to
# look into these paths when resolving .c to .obj dependencies.
-VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR):$(ZLIB_DIR)
+VPATH = $(GENERIC_DIR):$(WIN_DIR):$(COMPAT_DIR):$(ZLIB_DIR):$(TOMMATH_DIR)
AR = @AR@
RANLIB = @RANLIB@
@@ -201,24 +207,64 @@ 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 = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
--I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH \
--DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
+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"${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}
CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
--I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
+-I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
${COMPILE_DEBUG_FLAGS}
@@ -298,6 +344,7 @@ GENERIC_OBJS = \
tclPosixStr.$(OBJEXT) \
tclPreserve.$(OBJEXT) \
tclProc.$(OBJEXT) \
+ tclProcess.$(OBJEXT) \
tclRegexp.$(OBJEXT) \
tclResolve.$(OBJEXT) \
tclResult.$(OBJEXT) \
@@ -315,6 +362,7 @@ GENERIC_OBJS = \
tclUtf.$(OBJEXT) \
tclUtil.$(OBJEXT) \
tclVar.$(OBJEXT) \
+ tclZipfs.$(OBJEXT) \
tclZlib.$(OBJEXT)
TOMMATH_OBJS = \
@@ -337,12 +385,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} \
@@ -405,7 +457,8 @@ REG_OBJS = tclWinReg.$(OBJEXT)
STUB_OBJS = \
tclStubLib.$(OBJEXT) \
tclTomMathStubLib.$(OBJEXT) \
- tclOOStubLib.$(OBJEXT)
+ tclOOStubLib.$(OBJEXT) \
+ tclWinPanic.$(OBJEXT)
TCLSH_OBJS = tclAppInit.$(OBJEXT)
@@ -422,7 +475,7 @@ ZLIB_OBJS = \
uncompr.$(OBJEXT) \
zutil.$(OBJEXT)
-TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
+TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} @ZLIB_OBJS@ @TOMMATH_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
@@ -459,7 +512,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}
@@ -467,9 +520,37 @@ libraries:
doc:
+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)"
+ @( \
+ $(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \
+ (for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \
+ mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \
+ $(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \
+ done) && \
+ $(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \
+ $(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \
+ $(LN) ${REG_DLL_FILE} ${TCL_VFS_PATH}/reg/ \
+ ) || ( \
+ $(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}/reg; \
+ )
+ (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)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
+ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest $(TCLSH).manifest
@VC_MANIFEST_EMBED_EXE@
@@ -487,11 +568,16 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
@MAKE_STUB_LIB@ ${STUB_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}
@$(RM) ${TCL_LIB_FILE}
@@ -525,6 +611,14 @@ ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
$(COPY) $(ZLIB_DIR)/win32/${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.
@@ -555,6 +649,17 @@ 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 \
+ -DCFG_RUNTIME_PATH="\"$(bindir_native)\"" \
+ -DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
+ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
+ -DCFG_RUNTIME_LIBDIR="\"$(bindir_native)\"" \
+ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
+ $(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
@@ -576,6 +681,8 @@ 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)\"" \
+ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
@@ -591,6 +698,9 @@ tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c
tclOOStubLib.${OBJEXT}: tclOOStubLib.c
$(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @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
@@ -599,6 +709,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
@@ -611,18 +774,18 @@ 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.
+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)
-gentommath_h:
- $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \
- "$(TOMMATH_DIR_NATIVE)/tommath.h" \
- > "$(GENERIC_DIR_NATIVE)/tclTomMath.h"
-
-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)" ; \
+ @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
@@ -639,7 +802,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)/"; \
@@ -674,6 +837,11 @@ install-binaries: binaries
$(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
fi
+install-libraries-zipfs-shared: libraries
+
+install-libraries-zipfs-static: install-libraries-zipfs-shared
+ $(COPY) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
+
install-libraries: libraries install-tzdata install-msgs
@for i in "$(prefix)/lib" "$(INCLUDE_INSTALL_DIR)" \
"$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
@@ -684,7 +852,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"; \
@@ -692,7 +860,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"; \
@@ -700,34 +868,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 \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing library http1.0 directory";
- @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
+ @echo "Installing package cookiejar 0.2"
+ @for j in $(ROOT_DIR)/library/cookiejar/*.{tcl,txt.gz}; \
do \
- $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
@echo "Installing package http 2.9.2 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm";
- @echo "Installing library opt0.4 directory";
+ @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 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.3 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm";
@echo "Installing package platform 1.0.14 as a Tcl Module";
@@ -735,7 +894,7 @@ install-libraries: libraries install-tzdata install-msgs
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm";
@echo "Installing encodings";
- @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
+ @for i in $(ROOT_DIR)/library/encoding/*.enc; do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
done;
@@ -751,6 +910,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); \
@@ -778,19 +958,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
@@ -810,10 +990,13 @@ 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
+ $(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT}
+ $(RM) *.zip
+ $(RMDIR) *.vfs
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
- tcl.hpj config.status.lineno
+ tcl.hpj config.status.lineno tclsh.exe.manifest
#
# Bundled package targets
@@ -832,7 +1015,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); ) \
@@ -942,5 +1125,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: iinstall-libraries-zipfs-shared install-libraries-zipfs-static tclzipfile
# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/win/README b/win/README
index 2c74d48..117db7e 100644
--- a/win/README
+++ b/win/README
@@ -1,4 +1,4 @@
-Tcl 8.6 for Windows
+Tcl 8.7 for Windows
1. Introduction
---------------
@@ -16,7 +16,7 @@ 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
@@ -79,9 +79,9 @@ 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 is
+Note that in order to run tclsh87.exe, you must ensure that tcl87.dll is
on your path, in the system directory, or in the directory containing
-tclsh86.exe.
+tclsh87.exe.
Note: Tcl no longer provides support for Win32s.
diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat
index deb9e39..cb136be 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
diff --git a/win/coffbase.txt b/win/coffbase.txt
deleted file mode 100644
index 3314f26..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 hexidecimal.
-; The third token is the maximum size of the DLL image file, including symbols.
-;
-; Using a specified "prefered 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 cc5a3fc..e9ba659 100755
--- a/win/configure
+++ b/win/configure
@@ -1,81 +1,459 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.59.
+# Generated by GNU Autoconf 2.69.
+#
+#
+# Copyright (C) 1992-1996, 1998-2012 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
+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
+ # 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
+ 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
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
+else
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
fi
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; 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
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# 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
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+ done
+IFS=$as_save_IFS
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
+ ;;
+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
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
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
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+# 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'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+as_fn_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="if test -n \"\${ZSH_VERSION+set}\" && (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
+ 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
+ exitcode=1; echo positional parameters were not saved.
+fi
+test x\$exitcode = x0 || 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_have_required=no
+fi
+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then :
+
+else
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+as_found=false
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
do
- if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
- eval $as_var=C; export $as_var
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ 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_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ CONFIG_SHELL=$as_shell as_have_required=yes
+ if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then :
+ break 2
+fi
+fi
+ done;;
+ esac
+ as_found=false
+done
+$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then :
+ CONFIG_SHELL=$SHELL as_have_required=yes
+fi; }
+IFS=$as_save_IFS
+
+
+ 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'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
+fi
+
+ if test x$as_have_required = xno; then :
+ $as_echo "$0: This script requires a shell more modern than all"
+ $as_echo "$0: the shells that I found on your system."
+ if test x${ZSH_VERSION+set} = xset ; then
+ $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should"
+ $as_echo "$0: be upgraded to zsh 4.3.4 or later."
else
- $as_unset $as_var
+ $as_echo "$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
-done
+ 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_mkdir_p
+# -------------
+# Create "$as_dir" as a directory, including parents if necessary.
+as_fn_mkdir_p ()
+{
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
+ 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=`$as_echo "$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 ||
+$as_echo 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_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_fn_arith ()
+ {
+ as_val=`expr "$@" || test $? -eq 1`
+ }
+fi # as_fn_arith
+
+
+# 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
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
+ fi
+ $as_echo "$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 ||
+$as_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'
@@ -83,146 +461,91 @@ 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" ||
+ { $as_echo "$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= ;;
+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
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
else
- as_expr=false
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
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
+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,38 +554,25 @@ 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=
@@ -270,51 +580,229 @@ PACKAGE_TARNAME=
PACKAGE_VERSION=
PACKAGE_STRING=
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
+#ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>
#endif
-#if HAVE_SYS_STAT_H
+#ifdef HAVE_SYS_STAT_H
# include <sys/stat.h>
#endif
-#if STDC_HEADERS
+#ifdef STDC_HEADERS
# include <stdlib.h>
# include <stddef.h>
#else
-# if HAVE_STDLIB_H
+# ifdef HAVE_STDLIB_H
# include <stdlib.h>
# endif
#endif
-#if HAVE_STRING_H
-# if !STDC_HEADERS && HAVE_MEMORY_H
+#ifdef HAVE_STRING_H
+# if !defined STDC_HEADERS && defined HAVE_MEMORY_H
# include <memory.h>
# endif
# include <string.h>
#endif
-#if HAVE_STRINGS_H
+#ifdef HAVE_STRINGS_H
# include <strings.h>
#endif
-#if HAVE_INTTYPES_H
+#ifdef HAVE_INTTYPES_H
# include <inttypes.h>
-#else
-# if HAVE_STDINT_H
-# include <stdint.h>
-# endif
#endif
-#if HAVE_UNISTD_H
+#ifdef HAVE_STDINT_H
+# include <stdint.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 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_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_DBGX
+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
+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_WARNING
+CFLAGS_OPTIMIZE
+CFLAGS_DEBUG
+DL_LIBS
+WINE
+CYGPATH
+SHARED_BUILD
+SET_MAKE
+RC
+RANLIB
+AR
+EGREP
+GREP
+CPP
+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
+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 +825,49 @@ 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'
includedir='${prefix}/include'
oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
+docdir='${datarootdir}/doc/${PACKAGE}'
+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[^=]*=\(.*\)'`
+ case $ac_option in
+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
+ *=) ac_optarg= ;;
+ *) ac_optarg=yes ;;
+ esac
# Accept the important Cygnus configure options, so we can diagnose typos.
- case $ac_option in
+ case $ac_dashdash$ac_option in
+ --)
+ ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
@@ -386,33 +889,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=`$as_echo "$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=`$as_echo "$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 +968,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 +998,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,6 +1072,16 @@ 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 ;;
@@ -584,26 +1132,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=`$as_echo "$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=`$as_echo "$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 +1181,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
+ $as_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}
+ $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
@@ -651,31 +1208,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" ;;
+ *) $as_echo "$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
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 +1251,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 +1262,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 ||
+$as_echo 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.
@@ -792,20 +1350,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 +1370,25 @@ 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]
+ --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/PACKAGE]
+ --htmldir=DIR html documentation [DOCDIR]
+ --dvidir=DIR dvi documentation [DOCDIR]
+ --pdfdir=DIR pdf documentation [DOCDIR]
+ --psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
@@ -838,13 +1400,13 @@ if test -n "$ac_init_help"; then
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)
@@ -853,133 +1415,396 @@ 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$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 guested 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
else
- echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi
- cd $ac_popdir
+ $as_echo "$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
+configure
+generated by GNU Autoconf 2.69
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2012 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
+ 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\""
+$as_echo "$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
+ $as_echo "$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_echo "$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_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\""
+$as_echo "$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
+ $as_echo "$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_echo "$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_try_run LINENO
+# ----------------------
+# Try to link 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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; }; then :
+ ac_retval=0
+else
+ $as_echo "$as_me: program exited with status $ac_status" >&5
+ $as_echo "$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_header_mongrel LINENO HEADER VAR INCLUDES
+# -------------------------------------------------------
+# Tests whether HEADER exists, giving a warning if it cannot be compiled using
+# the include files in INCLUDES and setting the cache variable VAR
+# accordingly.
+ac_fn_c_check_header_mongrel ()
+{
+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
+ if eval \${$3+:} false; then :
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+else
+ # Is the header compilable?
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5
+$as_echo_n "checking $2 usability... " >&6; }
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+#include <$2>
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+ ac_header_compiler=yes
+else
+ ac_header_compiler=no
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5
+$as_echo "$ac_header_compiler" >&6; }
+
+# Is the header present?
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5
+$as_echo_n "checking $2 presence... " >&6; }
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include <$2>
+_ACEOF
+if ac_fn_c_try_cpp "$LINENO"; then :
+ ac_header_preproc=yes
+else
+ ac_header_preproc=no
+fi
+rm -f conftest.err conftest.i conftest.$ac_ext
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5
+$as_echo "$ac_header_preproc" >&6; }
+
+# So? What about this header?
+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #((
+ yes:no: )
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5
+$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5
+$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;}
+ ;;
+ no:yes:* )
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5
+$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5
+$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5
+$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5
+$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5
+$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;}
+ ;;
+esac
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ eval "$3=\$ac_header_compiler"
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+fi
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_header_mongrel
+
+# 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
+ eval "$3=no"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
+$as_echo_n "checking for $2... " >&6; }
+if eval \${$3+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ eval "$3=no"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+$4
+int
+main ()
+{
+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 ()
+{
+if (sizeof (($2)))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+
+else
+ eval "$3=yes"
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+eval ac_res=\$$3
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
+$as_echo "$ac_res" >&6; }
+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
+
+} # ac_fn_c_check_type
+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 $as_me, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
_ACEOF
+exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
@@ -998,7 +1823,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`
@@ -1010,8 +1835,9 @@ for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
- echo "PATH: $as_dir"
-done
+ $as_echo "PATH: $as_dir"
+ done
+IFS=$as_save_IFS
} >&5
@@ -1033,7 +1859,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
@@ -1044,13 +1869,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=`$as_echo "$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
@@ -1066,104 +1891,115 @@ 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=$?
# Save into config.log some information that might help in debugging.
{
echo
- cat <<\_ASBOX
-## ---------------- ##
+ $as_echo "## ---------------- ##
## 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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$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
-## ----------------- ##
+ $as_echo "## ----------------- ##
## 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=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
- cat <<\_ASBOX
-## ------------- ##
-## Output files. ##
-## ------------- ##
-_ASBOX
+ $as_echo "## ------------------- ##
+## 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=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
+ esac
+ $as_echo "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
- cat <<\_ASBOX
-## ----------- ##
+ $as_echo "## ----------- ##
## 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"
+ $as_echo "$as_me: caught signal $ac_signal"
+ $as_echo "$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
+rm -f -r conftest* confdefs.h
+
+$as_echo "/* confdefs.h */" > confdefs.h
# Predefined preprocessor variables.
@@ -1171,112 +2007,137 @@ 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
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_URL "$PACKAGE_URL"
+_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
+# Prefer an explicitly selected file to automatically selected ones.
+ac_site_file1=NONE
+ac_site_file2=NONE
+if test -n "$CONFIG_SITE"; then
+ # We do not want a PATH search for config.site.
+ case $CONFIG_SITE in #((
+ -*) ac_site_file1=./$CONFIG_SITE;;
+ */*) ac_site_file1=$CONFIG_SITE;;
+ *) ac_site_file1=./$CONFIG_SITE;;
+ esac
+elif test "x$prefix" != xNONE; then
+ ac_site_file1=$prefix/share/config.site
+ ac_site_file2=$prefix/etc/config.site
+else
+ ac_site_file1=$ac_default_prefix/share/config.site
+ ac_site_file2=$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_file1" "$ac_site_file2"
+do
+ test "x$ac_site_file" = xNONE && continue
+ if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
+$as_echo "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file"
+ . "$ac_site_file" \
+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
+$as_echo "$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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
+$as_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
+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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+$as_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;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
+$as_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=:
+ # 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
+$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ ac_cache_corrupted=:
+ else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
+$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
+ eval $ac_var=\$ac_old_val
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
+$as_echo "$as_me: former value: \`$ac_old_val'" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
+$as_echo "$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=`$as_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'" ;;
+ *) 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; }; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
+$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5
fi
+## -------------------- ##
+## Main body of script. ##
+## -------------------- ##
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
@@ -1287,32 +2148,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=".10"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a4"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.4
@@ -1363,10 +2207,10 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1376,35 +2220,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
@@ -1414,39 +2260,50 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+$as_echo "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1456,77 +2313,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1537,18 +2354,19 @@ 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
+ 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
+ $as_echo "$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.
@@ -1566,24 +2384,25 @@ fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
- echo "$as_me:$LINENO: result: $CC" >&5
-echo "${ECHO_T}$CC" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
@@ -1593,39 +2412,41 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
+$as_echo "$CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_CC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
@@ -1635,66 +2456,78 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
+$as_echo "$ac_ct_CC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+ CC=$ac_ct_CC
+ fi
fi
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; }; }
+test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+$as_echo "$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; 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\""
+$as_echo "$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
+ $as_echo "$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
@@ -1706,112 +2539,108 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
+$as_echo_n "checking whether the C compiler works... " >&6; }
+ac_link_default=`$as_echo "$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\""
+$as_echo "$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
+ $as_echo "$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+set}" = set && 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
+test "$ac_cv_exeext" = no && ac_cv_exeext=
+
else
- echo "$as_me: failed program was:" >&5
+ ac_file=''
+fi
+if test -z "$ac_file"; then :
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+$as_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; }; }
+{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
fi
-
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
+$as_echo_n "checking for C compiler default output file name... " >&6; }
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
+$as_echo_n "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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
ac_status=$?
- echo "$as_me:$LINENO: \$? = $ac_status" >&5
- (exit $ac_status); }; then
+ $as_echo "$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
@@ -1819,38 +2648,90 @@ 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; }; }
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
+$as_echo "$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 ()
+{
+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.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
+$as_echo_n "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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_link") 2>&5
+ ac_status=$?
+ $as_echo "$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\""
+$as_echo "$ac_try_echo"; } >&5
+ (eval "$ac_try") 2>&5
+ ac_status=$?
+ $as_echo "$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
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error $? "cannot run C compiled programs.
+If you meant to cross compile, use \`--host'.
+See \`config.log' for more details" "$LINENO" 5; }
+ fi
+ fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
+$as_echo "$cross_compiling" >&6; }
+
+rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
+ac_clean_files=$ac_clean_files_save
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
+$as_echo_n "checking for suffix of object files... " >&6; }
+if ${ac_cv_objext+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
@@ -1862,45 +2743,46 @@ 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\""
+$as_echo "$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
+ $as_echo "$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
+ $as_echo "$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; }; }
+{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
+$as_echo "$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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5
+$as_echo_n "checking whether we are using the GNU C compiler... " >&6; }
+if ${ac_cv_c_compiler_gnu+:} false; then :
+ $as_echo_n "(cached) " >&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. */
int
@@ -1914,55 +2796,34 @@ 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
+ ac_compiler_gnu=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext 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`
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
+$as_echo "$ac_cv_c_compiler_gnu" >&6; }
+if test $ac_compiler_gnu = yes; then
+ GCC=yes
+else
+ GCC=
+fi
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
-else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
+$as_echo_n "checking whether $CC accepts -g... " >&6; }
+if ${ac_cv_prog_cc_g+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
@@ -1973,39 +2834,49 @@ 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_cv_prog_cc_g=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+ CFLAGS=""
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main ()
+{
+
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_compile "$LINENO"; then :
+
+else
+ ac_c_werror_flag=$ac_save_c_werror_flag
+ CFLAGS="-g"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+
+int
+main ()
+{
-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 core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5
-echo "${ECHO_T}$ac_cv_prog_cc_g" >&6
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+ ac_c_werror_flag=$ac_save_c_werror_flag
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
+$as_echo "$ac_cv_prog_cc_g" >&6; }
if test "$ac_test_CFLAGS" = set; then
CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
@@ -2021,23 +2892,18 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5
+$as_echo_n "checking for $CC option to accept ISO C89... " >&6; }
+if ${ac_cv_prog_cc_c89+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- ac_cv_prog_cc_stdc=no
+ ac_cv_prog_cc_c89=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>
+struct stat;
/* 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);
@@ -2060,12 +2926,17 @@ static char *f (char * (*g) (char **, int), char **p, ...)
/* 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
+ as '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's necessary to write '\x00'==0 to get something
- that's true only with -std1. */
+ that's 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);};
@@ -2080,205 +2951,37 @@ return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];
return 0;
}
_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 '' -qlanglvl=extc89 -qlanglvl=ansi -std \
+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
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_c89=$ac_arg
fi
-rm -f conftest.err conftest.$ac_objext
+rm -f core conftest.err conftest.$ac_objext
+ test "x$ac_cv_prog_cc_c89" != "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 ;;
+# AC_CACHE_VAL
+case "x$ac_cv_prog_cc_c89" in
+ x)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
+$as_echo "none needed" >&6; } ;;
+ xno)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
+$as_echo "unsupported" >&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" ;;
+ CC="$CC $ac_cv_prog_cc_c89"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
+$as_echo "$ac_cv_prog_cc_c89" >&6; } ;;
esac
+if test "x$ac_cv_prog_cc_c89" != xno; then :
-# 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
-/* end confdefs.h. */
-$ac_declaration
-#include <stdlib.h>
-int
-main ()
-{
-exit (42);
- ;
- 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
- :
-else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-continue
-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
-/* end confdefs.h. */
-$ac_declaration
-int
-main ()
-{
-exit (42);
- ;
- 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
- 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_ext
-done
-rm -f conftest*
-if test -n "$ac_declaration"; then
- echo '#ifdef __cplusplus' >>confdefs.h
- echo $ac_declaration >>confdefs.h
- echo '#endif' >>confdefs.h
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
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
@@ -2286,18 +2989,14 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
+$as_echo_n "checking for inline... " >&6; }
+if ${ac_cv_c_inline+:} false; then :
+ $as_echo_n "(cached) " >&6
else
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;
@@ -2306,41 +3005,16 @@ $ac_kw foo_t foo () {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.$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
-
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
+$as_echo "$ac_cv_c_inline" >&6; }
case $ac_cv_c_inline in
inline | yes) ;;
@@ -2362,15 +3036,15 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
+$as_echo_n "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
+ if ${ac_cv_prog_CPP+:} false; then :
+ $as_echo_n "(cached) " >&6
else
# Double quotes because CPP needs to be expanded
for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp"
@@ -2384,11 +3058,7 @@ do
# <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>
@@ -2397,78 +3067,34 @@ cat >>conftest.$ac_ext <<_ACEOF
#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
+if ac_fn_c_try_cpp "$LINENO"; then :
+else
# 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
-
# 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
@@ -2480,8 +3106,8 @@ fi
else
ac_cv_prog_CPP=$CPP
fi
-echo "$as_me:$LINENO: result: $CPP" >&5
-echo "${ECHO_T}$CPP" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
+$as_echo "$CPP" >&6; }
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
@@ -2491,11 +3117,7 @@ do
# <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>
@@ -2504,85 +3126,40 @@ cat >>conftest.$ac_ext <<_ACEOF
#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
+if ac_fn_c_try_cpp "$LINENO"; then :
+else
# 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
-
# 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 :
+
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; }; }
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$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
@@ -2592,31 +3169,142 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
+$as_echo_n "checking for grep that handles long lines and -e... " >&6; }
+if ${ac_cv_path_GREP+:} false; then :
+ $as_echo_n "(cached) " >&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'
+ 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
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo '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
-echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5
-echo "${ECHO_T}$ac_cv_prog_egrep" >&6
- EGREP=$ac_cv_prog_egrep
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
+$as_echo "$ac_cv_path_GREP" >&6; }
+ GREP="$ac_cv_path_GREP"
-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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
+$as_echo_n "checking for egrep... " >&6; }
+if ${ac_cv_path_EGREP+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+ 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
+ test -z "$as_dir" && as_dir=.
+ 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
+ $as_echo_n 0123456789 >"conftest.in"
+ while :
+ do
+ cat "conftest.in" "conftest.in" >"conftest.tmp"
+ mv "conftest.tmp" "conftest.in"
+ cp "conftest.in" "conftest.nl"
+ $as_echo '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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
+$as_echo "$ac_cv_path_EGREP" >&6; }
+ EGREP="$ac_cv_path_EGREP"
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5
+$as_echo_n "checking for ANSI C header files... " >&6; }
+if ${ac_cv_header_stdc+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <stdarg.h>
@@ -2631,51 +3319,23 @@ 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_cv_header_stdc=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_header_stdc=no
+ ac_cv_header_stdc=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <string.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "memchr" >/dev/null 2>&1; then
- :
+ $EGREP "memchr" >/dev/null 2>&1; then :
+
else
ac_cv_header_stdc=no
fi
@@ -2685,18 +3345,14 @@ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP "free" >/dev/null 2>&1; then
- :
+ $EGREP "free" >/dev/null 2>&1; then :
+
else
ac_cv_header_stdc=no
fi
@@ -2706,16 +3362,13 @@ 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
+ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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))
@@ -2735,41 +3388,26 @@ main ()
for (i = 0; i < 256; i++)
if (XOR (islower (i), ISLOWER (i))
|| toupper (i) != TOUPPER (i))
- exit(2);
- exit (0);
+ return 2;
+ 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
- :
-else
- echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
+if ac_fn_c_try_run "$LINENO"; then :
-( exit $ac_status )
-ac_cv_header_stdc=no
+else
+ ac_cv_header_stdc=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
fi
-echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5
-echo "${ECHO_T}$ac_cv_header_stdc" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5
+$as_echo "$ac_cv_header_stdc" >&6; }
if test $ac_cv_header_stdc = yes; then
-cat >>confdefs.h <<\_ACEOF
-#define STDC_HEADERS 1
-_ACEOF
+$as_echo "#define STDC_HEADERS 1" >>confdefs.h
fi
@@ -2777,10 +3415,10 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_AR+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
@@ -2790,35 +3428,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
+$as_echo "$AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_AR+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_AR"; then
ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
@@ -2828,27 +3468,38 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
+$as_echo "$ac_ct_AR" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
@@ -2856,10 +3507,10 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_RANLIB+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
@@ -2869,35 +3520,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
+$as_echo "$RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_RANLIB+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_RANLIB"; then
ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
@@ -2907,27 +3560,38 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
+$as_echo "$ac_ct_RANLIB" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
@@ -2935,10 +3599,10 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_RC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$RC"; then
ac_cv_prog_RC="$RC" # Let the user override the test.
@@ -2948,35 +3612,37 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RC" >&5
+$as_echo "$RC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_RC+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$ac_ct_RC"; then
ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test.
@@ -2986,27 +3652,38 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5
+$as_echo "$ac_ct_RC" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "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:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$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
@@ -3016,12 +3693,12 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5
+$as_echo_n "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
+ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'`
+if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then :
+ $as_echo_n "(cached) " >&6
else
cat >conftest.make <<\_ACEOF
SHELL = /bin/sh
@@ -3038,12 +3715,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
SET_MAKE=
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
SET_MAKE="MAKE=${MAKE-make}"
fi
@@ -3055,54 +3732,17 @@ 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+set}" = set; then :
+ withval=$with_encoding; with_tcencoding=${withval}
+fi
+
if test x"${with_tcencoding}" != x ; then
cat >>confdefs.h <<_ACEOF
@@ -3111,9 +3751,7 @@ _ACEOF
else
# Default encoding on windows is not "iso8859-1"
- cat >>confdefs.h <<\_ACEOF
-#define TCL_CFGVAL_ENCODING "cp1252"
-_ACEOF
+ $as_echo "#define TCL_CFGVAL_ENCODING \"cp1252\"" >>confdefs.h
fi
@@ -3124,15 +3762,15 @@ _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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
+$as_echo_n "checking how to build libraries... " >&6; }
+ # Check whether --enable-shared was given.
+if test "${enable_shared+set}" = set; then :
+ enableval=$enable_shared; tcl_ok=$enableval
else
tcl_ok=yes
-fi;
+fi
+
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
@@ -3142,36 +3780,35 @@ fi;
fi
if test "$tcl_ok" = "yes" ; then
- echo "$as_me:$LINENO: result: shared" >&5
-echo "${ECHO_T}shared" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared" >&5
+$as_echo "shared" >&6; }
SHARED_BUILD=1
else
- echo "$as_me:$LINENO: result: static" >&5
-echo "${ECHO_T}static" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5
+$as_echo "static" >&6; }
SHARED_BUILD=0
-cat >>confdefs.h <<\_ACEOF
-#define STATIC_BUILD 1
-_ACEOF
+$as_echo "#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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking force of 64-bit time_t" >&5
+$as_echo_n "checking force of 64-bit time_t... " >&6; }
+# Check whether --enable-time64bit was given.
+if test "${enable_time64bit+set}" = set; then :
+ enableval=$enable_time64bit; tcl_ok=$enableval
else
tcl_ok=no
-fi;
-echo "$as_me:$LINENO: result: \"$tcl_ok\"" >&5
-echo "${ECHO_T}\"$tcl_ok\"" >&6
+fi
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: \"$tcl_ok\"" >&5
+$as_echo "\"$tcl_ok\"" >&6; }
if test "$tcl_ok" = "yes"; then
CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T"
fi
@@ -3182,63 +3819,51 @@ fi
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
+# On IRIX 5.3, sys/types and inttypes.h are conflicting.
+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=`$as_echo "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 `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1
+_ACEOF
+fi
- # Step 0: Enable 64 bit support?
+done
- 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
- 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
+ # Step 0: Enable 64 bit support?
-# Check whether --with-celib or --without-celib was given.
-if test "${with_celib+set}" = set; then
- withval="$with_celib"
- CELIB_DIR=$withval
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
+$as_echo_n "checking if 64bit support is requested... " >&6; }
+ # Check whether --enable-64bit was given.
+if test "${enable_64bit+set}" = set; then :
+ enableval=$enable_64bit; do64bit=$enableval
else
- CELIB_DIR=NO_CELIB
-fi;
- echo "$as_me:$LINENO: result: $CELIB_DIR" >&5
-echo "${ECHO_T}$CELIB_DIR" >&6
+ do64bit=no
+fi
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
+$as_echo "$do64bit" >&6; }
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
-cat >>confdefs.h <<\_ACEOF
-#define MODULE_SCOPE extern
-_ACEOF
+$as_echo "#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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_CYGPATH+:} false; then :
+ $as_echo_n "(cached) " >&6
else
if test -n "$CYGPATH"; then
ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test.
@@ -3248,28 +3873,67 @@ 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
+ 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
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5
+$as_echo "$CYGPATH" >&6; }
else
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
fi
+ # Extract the first word of "wine", so it can be a program name with args.
+set dummy wine; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_WINE+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
+ test -z "$as_dir" && as_dir=.
+ 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"
+ $as_echo "$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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $WINE" >&5
+$as_echo "$WINE" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
@@ -3278,16 +3942,12 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cross-compile version of gcc" >&5
+$as_echo_n "checking for cross-compile version of gcc... " >&6; }
+if ${ac_cv_cross+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#ifndef _WIN32
@@ -3302,40 +3962,16 @@ 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_cv_cross=no
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_cross=yes
+ ac_cv_cross=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_cross" >&5
-echo "${ECHO_T}$ac_cv_cross" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5
+$as_echo "$ac_cv_cross" >&6; }
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
@@ -3370,20 +4006,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Windows native path bug in windres" >&5
+$as_echo_n "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
+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
+ test $ac_status = 0; }; } ; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
else
- echo "$as_me:$LINENO: result: yes" >&5
-echo "${ECHO_T}yes" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
CYGPATH=echo
fi
conftest=
@@ -3401,16 +4037,12 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mingw32 version of gcc" >&5
+$as_echo_n "checking for mingw32 version of gcc... " >&6; }
+if ${ac_cv_win32+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#ifdef _WIN32
@@ -3425,57 +4057,73 @@ 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_cv_win32=no
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_win32=yes
+ ac_cv_win32=yes
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_win32" >&5
-echo "${ECHO_T}$ac_cv_win32" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_win32" >&5
+$as_echo "$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
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working -municode linker flag" >&5
+$as_echo_n "checking for working -municode linker flag... " >&6; }
+if ${ac_cv_municode+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h. */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
+
+# 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$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\""
+$as_echo "$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
+ $as_echo "$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_echo "$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>
@@ -3489,41 +4137,17 @@ 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_municode=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_municode=no
+ 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$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $ac_cv_municode" >&5
-echo "${ECHO_T}$ac_cv_municode" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_municode" >&5
+$as_echo "$ac_cv_municode" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_municode" = "yes" ; then
extra_ldflags="$extra_ldflags -municode"
@@ -3532,8 +4156,8 @@ echo "${ECHO_T}$ac_cv_municode" >&6
fi
fi
- echo "$as_me:$LINENO: checking compiler flags" >&5
-echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking compiler flags" >&5
+$as_echo_n "checking compiler flags... " >&6; }
if test "${GCC}" = "yes" ; then
SHLIB_LD=""
SHLIB_LD_LIBS='${LIBS}'
@@ -3554,23 +4178,20 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
+$as_echo "using static flags" >&6; }
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
# dynamic
- echo "$as_me:$LINENO: result: using shared flags" >&5
-echo "${ECHO_T}using shared flags" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
+$as_echo "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=
@@ -3596,7 +4217,7 @@ echo "$as_me: error: ${CC} does not support the -shared option.
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
- CFLAGS_WARNING="-Wall -Wpointer-arith"
+ CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
@@ -3605,7 +4226,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 -Wdeclaration-after-statement"
;;
esac
@@ -3633,20 +4254,16 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+$as_echo " Using 64-bit $MACHINE mode" >&6; }
;;
ia64)
MACHINE="IA64"
- echo "$as_me:$LINENO: result: Using 64-bit $MACHINE mode" >&5
-echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+$as_echo " Using 64-bit $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
@@ -3661,57 +4278,33 @@ 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_win_64bit=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_win_64bit=no
+ tcl_win_64bit=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+$as_echo " 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5
+$as_echo "using static flags" >&6; }
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
# dynamic
- echo "$as_me:$LINENO: result: using shared flags" >&5
-echo "${ECHO_T}using shared flags" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5
+$as_echo "using shared flags" >&6; }
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
LIBRARIES="\${SHARED_LIBRARIES}"
@@ -3740,8 +4333,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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
+$as_echo " Using 64-bit $MACHINE mode" >&6; }
fi
LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
@@ -3775,111 +4368,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"
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
SHLIB_LD_LIBS='${LIBS}'
@@ -3910,7 +4399,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
@@ -3920,26 +4409,20 @@ _ACEOF
fi
if test "$do64bit" != "no" ; then
- cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_DO64BIT 1
-_ACEOF
+ $as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for SEH support in compiler" >&5
+$as_echo_n "checking for SEH support in compiler... " >&6; }
+if ${tcl_cv_seh+:} false; then :
+ $as_echo_n "(cached) " >&6
else
- if test "$cross_compiling" = yes; then
+ 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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
@@ -3958,37 +4441,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_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
+ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_seh" >&5
+$as_echo "$tcl_cv_seh" >&6; }
if test "$tcl_cv_seh" = "no" ; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_SEH 1
-_ACEOF
+$as_echo "#define HAVE_NO_SEH 1" >>confdefs.h
fi
@@ -3998,16 +4466,12 @@ _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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for EXCEPTION_DISPOSITION support in include files" >&5
+$as_echo_n "checking for EXCEPTION_DISPOSITION support in include files... " >&6; }
+if ${tcl_cv_eh_disposition+:} false; then :
+ $as_echo_n "(cached) " >&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. */
# define WIN32_LEAN_AND_MEAN
@@ -4024,45 +4488,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_eh_disposition=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_eh_disposition=no
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5
-echo "${ECHO_T}$tcl_cv_eh_disposition" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_eh_disposition" >&5
+$as_echo "$tcl_cv_eh_disposition" >&6; }
if test "$tcl_cv_eh_disposition" = "no" ; then
-cat >>confdefs.h <<\_ACEOF
-#define EXCEPTION_DISPOSITION int
-_ACEOF
+$as_echo "#define EXCEPTION_DISPOSITION int" >>confdefs.h
fi
@@ -4070,16 +4508,12 @@ _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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for winnt.h that ignores VOID define" >&5
+$as_echo_n "checking for winnt.h that ignores VOID define... " >&6; }
+if ${tcl_cv_winnt_ignore_void+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#define VOID void
@@ -4099,62 +4533,41 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5
-echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5
+$as_echo "$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
+$as_echo "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h
fi
+ ac_fn_c_check_header_mongrel "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
+if test "x$ac_cv_header_stdbool_h" = xyes; then :
+
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
+$as_echo_n "checking for cast to union support... " >&6; }
+if ${tcl_cv_cast_to_union+:} false; then :
+ $as_echo_n "(cached) " >&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. */
int
@@ -4168,45 +4581,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_cast_to_union=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cast_to_union=no
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
-echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
+$as_echo "$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
+$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
fi
@@ -4229,11 +4616,12 @@ 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
@@ -4243,244 +4631,98 @@ else
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
-
- if test "$GCC" == "yes"; then
-
- ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
-
-
-else
+ TOMMATH_DLL_FILE=\${TOMMATH_DLL_FILE}
- ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
+$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
-fi
+ if test "$do64bit" != "no"; then :
-else
+$as_echo "#define MP_64BIT 1" >>confdefs.h
- ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
+ if test "$GCC" == "yes"; then :
+ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
-fi
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a
else
- ZLIB_OBJS=\${ZLIB_OBJS}
-
-
-fi
-
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_ZLIB 1
-_ACEOF
-
+ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
-# On IRIX 5.3, sys/types and inttypes.h are conflicting.
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib
+fi
+else
+ ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
+ TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win32/tommath.lib
+fi
+else
-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
+ ZLIB_OBJS=\${ZLIB_OBJS}
-#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
+ TOMMATH_OBJS=\${TOMMATH_OBJS}
-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
-done
+$as_echo "#define HAVE_ZLIB 1" >>confdefs.h
-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_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "$ac_includes_default"
+if test "x$ac_cv_type_intptr_t" = xyes; then :
-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
+$as_echo "#define HAVE_INTPTR_T 1" >>confdefs.h
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size signed integer type" >&5
+$as_echo_n "checking for pointer-size signed integer type... " >&6; }
+if ${tcl_cv_intptr_t+:} false; then :
+ $as_echo_n "(cached) " >&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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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
+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 :
tcl_ok=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
+ tcl_ok=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intptr_t" >&5
+$as_echo "$tcl_cv_intptr_t" >&6; }
if test "$tcl_cv_intptr_t" != none; then
cat >>confdefs.h <<_ACEOF
@@ -4491,132 +4733,48 @@ _ACEOF
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_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "$ac_includes_default"
+if test "x$ac_cv_type_uintptr_t" = xyes; then :
-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
+$as_echo "#define HAVE_UINTPTR_T 1" >>confdefs.h
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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size unsigned integer type" >&5
+$as_echo_n "checking for pointer-size unsigned integer type... " >&6; }
+if ${tcl_cv_uintptr_t+:} false; then :
+ $as_echo_n "(cached) " >&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
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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
+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 :
tcl_ok=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_ok=no
+ tcl_ok=no
fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+rm -f core 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_uintptr_t" >&5
+$as_echo "$tcl_cv_uintptr_t" >&6; }
if test "$tcl_cv_uintptr_t" != none; then
cat >>confdefs.h <<_ACEOF
@@ -4628,6 +4786,208 @@ _ACEOF
fi
+
+#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+# Check whether --enable-zipfs was given.
+if test "${enable_zipfs+set}" = set; then :
+ enableval=$enable_zipfs; tcl_ok=$enableval
+else
+ tcl_ok=yes
+fi
+
+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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gcc" >&5
+$as_echo_n "checking for gcc... " >&6; }
+ if ${ac_cv_path_cc+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+
+ 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'
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build system executable suffix" >&5
+$as_echo_n "checking for build system executable suffix... " >&6; }
+if ${bfd_cv_build_exeext+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $bfd_cv_build_exeext" >&5
+$as_echo "$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
+ #
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
+$as_echo_n "checking for tclsh... " >&6; }
+
+ if ${ac_cv_path_tclsh+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+
+ 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
+
+fi
+
+
+ if test -f "$ac_cv_path_tclsh" ; then
+ TCLSH_PROG="$ac_cv_path_tclsh"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
+$as_echo "$TCLSH_PROG" >&6; }
+ else
+ # It is not an error if an installed version of Tcl can't be located.
+ TCLSH_PROG=""
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
+$as_echo "No tclsh found on PATH" >&6; }
+ fi
+
+
+
+ ZIP_PROG=""
+ ZIP_PROG_OPTIONS=""
+ ZIP_PROG_VFSSEARCH=""
+ ZIP_INSTALL_OBJS=""
+
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for zip" >&5
+$as_echo_n "checking for zip... " >&6; }
+ if ${ac_cv_path_zip+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+
+ 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"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ZIP_PROG" >&5
+$as_echo "$ZIP_PROG" >&6; }
+ ZIP_PROG_OPTIONS="-rq"
+ ZIP_PROG_VFSSEARCH="*"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: Found INFO Zip in environment" >&5
+$as_echo "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}"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: No zip found on PATH building minizip" >&5
+$as_echo "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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
+$as_echo_n "checking for building with zipfs... " >&6; }
+if test "${ZIPFS_BUILD}" = 1; then
+ if test "${SHARED_BUILD}" = 0; then
+ ZIPFS_BUILD=2;
+
+$as_echo "#define ZIPFS_BUILD 2" >>confdefs.h
+
+ INSTALL_LIBRARIES=install-libraries-zipfs-static
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+ else
+
+$as_echo "#define ZIPFS_BUILD 1" >>confdefs.h
+\
+ INSTALL_LIBRARIES=install-libraries-zipfs-shared
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+ fi
+else
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+INSTALL_LIBRARIES=install-libraries
+INSTALL_MSGS=install-msgs
+fi
+
+
+
+
+
+
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
@@ -4636,16 +4996,12 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
+$as_echo_n "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; }
+if ${tcl_cv_findex_enums+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#define WIN32_LEAN_AND_MEAN
@@ -4663,60 +5019,30 @@ 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
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
-echo "${ECHO_T}$tcl_cv_findex_enums" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5
+$as_echo "$tcl_cv_findex_enums" >&6; }
if test "$tcl_cv_findex_enums" = "no"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_FINDEX_ENUMS 1
-_ACEOF
+$as_echo "#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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for intrinsics support in compiler" >&5
+$as_echo_n "checking for intrinsics support in compiler... " >&6; }
+if ${tcl_cv_intrinsics+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#define WIN32_LEAN_AND_MEAN
@@ -4734,61 +5060,31 @@ 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
+ 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$ac_exeext conftest.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_intrinsics" >&5
-echo "${ECHO_T}$tcl_cv_intrinsics" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intrinsics" >&5
+$as_echo "$tcl_cv_intrinsics" >&6; }
if test "$tcl_cv_intrinsics" = "yes"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_INTRIN_H 1
-_ACEOF
+$as_echo "#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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for wspiapi.h" >&5
+$as_echo_n "checking for wspiapi.h... " >&6; }
+if ${tcl_cv_wspiapi_h+:} false; then :
+ $as_echo_n "(cached) " >&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 <wspiapi.h>
@@ -4801,45 +5097,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_wspiapi_h=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_wspiapi_h=no
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_wspiapi_h" >&5
-echo "${ECHO_T}$tcl_cv_wspiapi_h" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_wspiapi_h" >&5
+$as_echo "$tcl_cv_wspiapi_h" >&6; }
if test "$tcl_cv_wspiapi_h" = "yes"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_WSPIAPI_H 1
-_ACEOF
+$as_echo "#define HAVE_WSPIAPI_H 1" >>confdefs.h
fi
@@ -4847,16 +5117,12 @@ 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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
+$as_echo_n "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; }
+if ${tcl_cv_findex_enums+:} false; then :
+ $as_echo_n "(cached) " >&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. */
#define WIN32_LEAN_AND_MEAN
@@ -4874,45 +5140,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_findex_enums=yes
else
- echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_findex_enums=no
+ 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.$ac_ext
fi
-echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
-echo "${ECHO_T}$tcl_cv_findex_enums" >&6
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5
+$as_echo "$tcl_cv_findex_enums" >&6; }
if test "$tcl_cv_findex_enums" = "no"; then
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_FINDEX_ENUMS 1
-_ACEOF
+$as_echo "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h
fi
@@ -4923,39 +5163,35 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
+$as_echo_n "checking for build with symbols... " >&6; }
+ # Check whether --enable-symbols was given.
+if test "${enable_symbols+set}" = set; then :
+ enableval=$enable_symbols; tcl_ok=$enableval
else
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
+$as_echo "#define NDEBUG 1" >>confdefs.h
- echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
- cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_OPTIMIZED 1
-_ACEOF
+ $as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
+$as_echo "yes (standard debugging)" >&6; }
fi
fi
@@ -4963,32 +5199,26 @@ 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
+$as_echo "#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
+$as_echo "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
-cat >>confdefs.h <<\_ACEOF
-#define TCL_COMPILE_STATS 1
-_ACEOF
+$as_echo "#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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
+$as_echo "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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
+$as_echo "enabled $tcl_ok debugging" >&6; }
fi
fi
@@ -5000,15 +5230,15 @@ TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
- 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to embed manifest" >&5
+$as_echo_n "checking whether to embed manifest... " >&6; }
+ # Check whether --enable-embedded-manifest was given.
+if test "${enable_embedded_manifest+set}" = set; then :
+ enableval=$enable_embedded_manifest; embed_ok=$enableval
else
embed_ok=yes
-fi;
+fi
+
VC_MANIFEST_EMBED_DLL=
VC_MANIFEST_EMBED_EXE=
@@ -5016,11 +5246,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
@@ -5029,7 +5255,7 @@ 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
@@ -5048,8 +5274,8 @@ fi
rm -f conftest*
fi
- echo "$as_me:$LINENO: result: $result" >&5
-echo "${ECHO_T}$result" >&6
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $result" >&5
+$as_echo "$result" >&6; }
@@ -5236,7 +5462,8 @@ 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 tcl.hpj tclsh.exe.manifest"
+
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
@@ -5255,39 +5482,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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
+$as_echo "$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
+ :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
+ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
+$as_echo "$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"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
+$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
@@ -5296,63 +5554,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=`$as_echo "$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
@@ -5360,12 +5610,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
+{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
+$as_echo "$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.
@@ -5375,81 +5627,253 @@ 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
+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
+ # 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
+ 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
+
+as_nl='
+'
+export as_nl
+# Printing a long string crashes Solaris 7 /usr/bin/printf.
+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo
+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo
+# Prefer a ksh shell builtin over an external printf program on Solaris,
+# but without wasting forks for bash or zsh.
+if test -z "$BASH_VERSION$ZSH_VERSION" \
+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='print -r --'
+ as_echo_n='print -rn --'
+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then
+ as_echo='printf %s\n'
+ as_echo_n='printf %s'
+else
+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then
+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'
+ as_echo_n='/usr/ucb/echo -n'
+ else
+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'
+ as_echo_n_body='eval
+ arg=$1;
+ case $arg in #(
+ *"$as_nl"*)
+ expr "X$arg" : "X\\(.*\\)$as_nl";
+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;
+ esac;
+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"
+ '
+ export as_echo_n_body
+ as_echo_n='sh -c $as_echo_n_body as_echo'
+ fi
+ export as_echo_body
+ as_echo='sh -c $as_echo_body as_echo'
fi
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; 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
+
+
+# IFS
+# We need space, tab and new line, in precisely that order. Quoting is
+# there to prevent editors from complaining about space-tab.
+# (If _AS_PATH_WALK were called with IFS unset, it would disable word
+# splitting by setting IFS to empty value.)
+IFS=" "" $as_nl"
+
+# 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
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+ done
+IFS=$as_save_IFS
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
+ ;;
+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
+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
+ exit 1
+fi
+
+# Unset variables that we do not need and which cause bugs (e.g. in
+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"
+# suppresses any "Segmentation fault" message there. '((' could
+# trigger a bug in pdksh 5.2.14.
+for as_var in BASH_ENV ENV MAIL MAILPATH
+do eval test x\${$as_var+set} = xset \
+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
+done
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
+LC_ALL=C
+export LC_ALL
+LANGUAGE=C
+export LANGUAGE
+
+# CDPATH.
+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+
+
+# 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
+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
-done
+ $as_echo "$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_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_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 ||
+$as_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'
@@ -5457,148 +5881,111 @@ 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= ;;
+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
+rm -f conf$$ conf$$.exe conf$$.file
+if test -d conf$$.dir; then
+ rm -f conf$$.dir/conf$$.file
else
- as_expr=false
+ rm -f conf$$.dir
+ mkdir conf$$.dir 2>/dev/null
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
+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=`$as_echo "$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 ||
+$as_echo 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'"
@@ -5607,31 +5994,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
-
+# values after options handling.
+ac_log="
This file was extended by $as_me, which was
-generated by GNU Autoconf 2.59. Invocation command line was
+generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
@@ -5639,124 +6015,116 @@ 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
+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
+ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
config.status
-configured by $0, generated by GNU Autoconf 2.59,
- with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"
+configured by $0, generated by GNU Autoconf 2.69,
+ with options \\"\$ac_cs_config\\"
-Copyright (C) 2003 Free Software Foundation, Inc.
+Copyright (C) 2012 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 )
+ $as_echo "$ac_cs_version"; exit ;;
+ --config | --confi | --conf | --con | --co | --c )
+ $as_echo "$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=`$as_echo "$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 )
+ $as_echo "$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
@@ -5770,33 +6138,47 @@ 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
+ \$as_echo "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
+ $as_echo "$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" ;;
+ "tcl.hpj") CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;;
+ "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
@@ -5806,421 +6188,414 @@ if $ac_need_defaults; then
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,@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=`$as_echo "$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 '`
+ $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
+ `' by configure.'
+ if test x"$ac_file" != x-; then
+ configure_input="$ac_file. $configure_input"
+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
+$as_echo "$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=`$as_echo "$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 ||
+$as_echo 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
+ # A ".." for each directory in $ac_dir_suffix.
+ ac_top_builddir_sub=`$as_echo "$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@*)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
+$as_echo "$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"; } &&
+ { $as_echo "$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
+$as_echo "$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
+ esac
+
+done # for ac_tag
+
-{ (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.
@@ -6240,7 +6615,11 @@ 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
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
+$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
diff --git a/win/configure.in b/win/configure.ac
index d1b2b20..08f420a 100644
--- a/win/configure.in
+++ b/win/configure.ac
@@ -4,17 +4,17 @@
# to configure the system for the local environment.
AC_INIT(../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=".10"
+TCL_MINOR_VERSION=7
+TCL_PATCH_LEVEL="a4"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.4
@@ -78,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
#------------------------------------------------------------------------
@@ -130,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"], [
@@ -142,17 +137,24 @@ 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 "$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?])
@@ -188,6 +190,54 @@ AC_CHECK_TYPE([uintptr_t], [
fi
])
+
+#--------------------------------------------------------------------
+# Zipfs support - Tip 430
+#--------------------------------------------------------------------
+AC_ARG_ENABLE(zipfs,
+ AC_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?])
+ INSTALL_LIBRARIES=install-libraries-zipfs-static
+ AC_MSG_RESULT([yes])
+ else
+ AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\
+ INSTALL_LIBRARIES=install-libraries-zipfs-shared
+ AC_MSG_RESULT([yes])
+ fi
+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.
#--------------------------------------------------------------------
diff --git a/win/makefile.vc b/win/makefile.vc
index acdb3a6..c6b53d0 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -159,6 +159,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
@@ -193,7 +196,6 @@ 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 \
@@ -216,6 +218,7 @@ TCLTESTOBJS = \
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+ $(OUT_DIR)\tommath.lib \
!endif
$(TMP_DIR)\testMain.obj
@@ -288,6 +291,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 \
@@ -305,8 +309,10 @@ COREOBJS = \
$(TMP_DIR)\tclUtf.obj \
$(TMP_DIR)\tclUtil.obj \
$(TMP_DIR)\tclVar.obj \
+ $(TMP_DIR)\tclZipfs.obj \
$(TMP_DIR)\tclZlib.obj
+!if $(STATIC_BUILD)
ZLIBOBJS = \
$(TMP_DIR)\adler32.obj \
$(TMP_DIR)\compress.obj \
@@ -319,7 +325,11 @@ ZLIBOBJS = \
$(TMP_DIR)\trees.obj \
$(TMP_DIR)\uncompr.obj \
$(TMP_DIR)\zutil.obj
+!else
+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 +350,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 \
@@ -359,7 +372,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 \
@@ -383,6 +397,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 \
@@ -411,7 +428,8 @@ 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.
@@ -442,9 +460,9 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT)
release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
core: setup $(TCLLIB) $(TCLSTUBLIB)
shell: setup $(TCLSH)
-dlls: setup $(TCLREGLIB) $(TCLDDELIB)
-all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs
-tcltest: setup $(TCLTEST) dlls $(CAT32)
+dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
+tcltest: setup $(TCLTEST) dlls
install: install-binaries install-libraries install-docs install-pkgs
!if $(SYMBOLS)
install: install-pdbs
@@ -452,14 +470,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.3 [list load "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.5 [list load "$(TCLREGLIB:\=/)" registry]
<<
-runtest: setup $(TCLTEST) dlls $(CAT32)
+runtest: setup $(TCLTEST) dlls
set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLTEST) $(SCRIPT)
@@ -515,6 +533,27 @@ $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB)
$(_VC_MANIFEST_EMBED_DLL)
!endif
+!if "$(MACHINE)" == "AMD64"
+$(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
+!else
+$(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
+!endif
+
+
pkgs:
@for /d %d in ($(PKGSDIR)\*) do \
@if exist "%~fd\win\makefile.vc" ( \
@@ -547,12 +586,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]
#---------------------------------------------------------------------
@@ -569,21 +602,6 @@ genstubs:
!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.
#---------------------------------------------------------------------
@@ -646,7 +664,6 @@ $(OUT_DIR)\tcl.nmake:
@type << >$@
CORE_MACHINE = $(MACHINE)
CORE_DEBUG = $(DEBUG)
-CORE_TCL_THREADS = $(TCL_THREADS)
CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC)
<<
@@ -701,7 +718,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)
@@ -751,6 +767,9 @@ $(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$@ $?
@@ -766,6 +785,8 @@ $(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="\"$(CFG_RUNTIME_DLLFILE:\=\\)\"" \
+ /DCFG_RUNTIME_ZIPFILE="\"$(CFG_RUNTIME_ZIPFILE:\=\\)\"" \
-Fo$@ $?
$(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c
@@ -774,7 +795,6 @@ $(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c
-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$@ $?
@@ -797,6 +817,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)
@@ -868,6 +891,8 @@ install-binaries:
@$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\"
!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)\"
@@ -880,6 +905,8 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
@if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2"
@if not exist "$(MODULE_INSTALL_DIR)" \
$(MKDIR) "$(MODULE_INSTALL_DIR)"
@if not exist "$(MODULE_INSTALL_DIR)\8.4" \
@@ -890,6 +917,8 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
@if not exist "$(MODULE_INSTALL_DIR)\8.6" \
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
+ @if not exist "$(MODULE_INSTALL_DIR)\8.7" \
+ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.7"
@if not exist "$(LIB_INSTALL_DIR)\nmake" \
$(MKDIR) "$(LIB_INSTALL_DIR)\nmake"
@echo Installing header files
@@ -900,6 +929,7 @@ 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)\"
@echo Installing library files to $(SCRIPT_INSTALL_DIR)
@$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"
@@ -917,9 +947,11 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
@$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(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\"
+ @echo Installing package cookiejar $(PKG_COOKIEJAR_VER)
+ @$(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)
@$(CPY) "$(ROOT)\library\opt\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\opt0.4\"
@@ -928,7 +960,7 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
"$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
@$(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
@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
"$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
diff --git a/win/tcl.dsp b/win/tcl.dsp
index e8b1a33..065d598 100644
--- a/win/tcl.dsp
+++ b/win/tcl.dsp
@@ -36,7 +36,7 @@ CFG=tcl - Win32 Debug Static
# PROP BASE Intermediate_Dir "Release\tcl_Dynamic"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=none 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
@@ -45,7 +45,7 @@ CFG=tcl - Win32 Debug Static
# PROP Intermediate_Dir "Release\tcl_Dynamic"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads 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
@@ -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
@@ -1528,6 +1516,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
index a94cea6..08d411d 100644
--- a/win/tcl.hpj.in
+++ b/win/tcl.hpj.in
@@ -5,9 +5,9 @@ HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
+CNT=tcl87.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl86.hlp
+HLP=tcl87.hlp
[FILES]
tcl.rtf
diff --git a/win/tcl.m4 b/win/tcl.m4
index c62af68..ca04f84 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -251,6 +251,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [
# TCL_BIN_DIR
# TCL_SRC_DIR
# TCL_LIB_FILE
+# TCL_ZIP_FILE
#
#------------------------------------------------------------------------
@@ -283,6 +284,7 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [
# eval is required to do the TCL_DBGX substitution
#
+ eval "TCL_ZIP_FILE=\"${TCL_ZIP_FILE}\""
eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
@@ -295,6 +297,7 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
+ AC_SUBST(TCL_ZIP_FILE)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
@@ -380,42 +383,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)
])
#------------------------------------------------------------------------
@@ -544,22 +512,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"
@@ -727,7 +685,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
- CFLAGS_WARNING="-Wall -Wpointer-arith"
+ CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
@@ -736,7 +694,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 -Wdeclaration-after-statement"
;;
esac
@@ -858,98 +816,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"
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
SHLIB_LD_LIBS='${LIBS}'
@@ -980,7 +847,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
@@ -1068,6 +935,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.
@@ -1113,13 +982,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)
@@ -1284,3 +1153,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 be5e0a7..477512d 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 2236da3..59c21e5 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -87,17 +87,18 @@ MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv);
int
main(
int argc, /* Number of command-line arguments. */
- char *dummy[]) /* Not used. */
+ char **argv1)
{
TCHAR **argv;
+ TCHAR *p;
#else
int
_tmain(
int argc, /* Number of command-line arguments. */
TCHAR *argv[]) /* Values of command-line arguments. */
{
-#endif
TCHAR *p;
+#endif
/*
* Set up the default locale to be standard "C" locale so parsing is
@@ -111,6 +112,7 @@ _tmain(
* Get our args from the c-runtime. Ignore command line.
*/
+ (void)argv1;
setargv(&argc, &argv);
#endif
@@ -126,6 +128,9 @@ _tmain(
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
+#elif !defined(_WIN32) || defined(UNICODE)
+ /* This doesn't work on Windows without UNICODE */
+ TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
@@ -265,10 +270,10 @@ 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 = ckalloc(size * sizeof(char *)
+ argSpace = (TCHAR *)ckalloc(size * sizeof(char *)
+ (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
argv = (TCHAR **) argSpace;
argSpace += size * (sizeof(char *)/sizeof(TCHAR));
diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in
index 6ed06e2..5dc6833 100644
--- a/win/tclConfig.sh.in
+++ b/win/tclConfig.sh.in
@@ -41,6 +41,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 +80,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 +178,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 9061dd0..f667b05 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -90,7 +90,7 @@ BOOL APIENTRY
DllEntryPoint(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
- LPVOID reserved) /* Not used. */
+ LPVOID reserved)
{
return DllMain(hInst, reason, reserved);
}
@@ -117,10 +117,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);
@@ -197,30 +195,6 @@ TclWinInit(
}
/*
- *----------------------------------------------------------------------
- *
- * 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 +263,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 +463,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 +473,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 +485,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 = 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,8 +510,8 @@ 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;
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 4f210cb..544c000 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -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,8 +85,10 @@ 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);
+#endif
static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
Tcl_WideInt offset, int mode, int *errorCode);
static void FileSetupProc(ClientData clientData, int flags);
@@ -98,6 +99,7 @@ static int FileTruncateProc(ClientData instanceData,
Tcl_WideInt length);
static DWORD FileGetType(HANDLE handle);
static int NativeIsComPort(const WCHAR *nativeName);
+
/*
* This structure describes the channel type structure for file based IO.
*/
@@ -105,15 +107,19 @@ static int NativeIsComPort(const WCHAR *nativeName);
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. */
@@ -121,6 +127,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)
/*
*----------------------------------------------------------------------
@@ -142,7 +156,7 @@ static ThreadSpecificData *
FileInit(void)
{
ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -172,7 +186,7 @@ FileInit(void)
static void
FileChannelExitHandler(
- ClientData clientData) /* Old window proc */
+ TCL_UNUSED(ClientData))
{
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
}
@@ -196,14 +210,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);
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return;
}
@@ -239,14 +253,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);
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return;
}
@@ -257,9 +271,9 @@ FileCheckProc(
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
- if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
- infoPtr->flags |= FILE_PENDING;
- evPtr = ckalloc(sizeof(FileEvent));
+ 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;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -298,7 +312,7 @@ FileEventProc(
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return 0;
}
@@ -312,7 +326,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;
}
@@ -342,7 +356,7 @@ FileBlockProc(
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
/*
* Files on Windows can not be switched between blocking and nonblocking,
@@ -352,9 +366,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;
}
@@ -362,7 +376,7 @@ FileBlockProc(
/*
*----------------------------------------------------------------------
*
- * FileCloseProc/FileClose2Proc --
+ * FileCloseProc --
*
* Closes the IO channel.
*
@@ -378,13 +392,18 @@ FileBlockProc(
static int
FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
- Tcl_Interp *interp) /* Not used. */
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
{
- FileInfo *fileInfoPtr = instanceData;
+ FileInfo *fileInfoPtr = (FileInfo *)instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
/*
* Remove the file from the watch list.
*/
@@ -429,18 +448,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;
-}
/*
*----------------------------------------------------------------------
@@ -459,7 +466,7 @@ FileClose2Proc(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
ClientData instanceData, /* File state. */
@@ -467,7 +474,7 @@ FileSeekProc(
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
DWORD moveMethod;
@@ -486,7 +493,7 @@ FileSeekProc(
oldPosHigh = 0;
oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
- if (oldPos == (LONG)INVALID_SET_FILE_POINTER) {
+ if (oldPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
@@ -498,7 +505,7 @@ FileSeekProc(
newPosHigh = (offset < 0 ? -1 : 0);
newPos = SetFilePointer(infoPtr->handle, offset, &newPosHigh, moveMethod);
- if (newPos == (LONG)INVALID_SET_FILE_POINTER) {
+ if (newPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
if (winError != NO_ERROR) {
@@ -519,6 +526,7 @@ FileSeekProc(
}
return (int) newPos;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -545,7 +553,7 @@ FileWideSeekProc(
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD moveMethod;
LONG newPos, newPosHigh;
@@ -558,10 +566,10 @@ FileWideSeekProc(
moveMethod = FILE_END;
}
- newPosHigh = Tcl_WideAsLong(offset >> 32);
- newPos = 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) {
@@ -570,7 +578,8 @@ FileWideSeekProc(
return -1;
}
}
- return (((Tcl_WideInt)((unsigned)newPos)) | (Tcl_LongAsWide(newPosHigh) << 32));
+ return (((Tcl_WideInt)((unsigned)newPos))
+ | ((Tcl_WideInt)newPosHigh << 32));
}
/*
@@ -594,7 +603,7 @@ FileTruncateProc(
ClientData instanceData, /* File state. */
Tcl_WideInt length) /* Length to truncate at. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
/*
@@ -603,8 +612,9 @@ FileTruncateProc(
oldPosHigh = 0;
oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
- if (oldPos == (LONG)INVALID_SET_FILE_POINTER) {
+ if (oldPos == (LONG) INVALID_SET_FILE_POINTER) {
DWORD winError = GetLastError();
+
if (winError != NO_ERROR) {
TclWinConvertError(winError);
return errno;
@@ -615,11 +625,12 @@ FileTruncateProc(
* Move to where we want to truncate
*/
- newPosHigh = Tcl_WideAsLong(length >> 32);
- newPos = 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);
return errno;
@@ -670,15 +681,15 @@ FileInputProc(
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesRead;
*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
@@ -725,7 +736,7 @@ FileOutputProc(
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesWritten;
*errorCode = 0;
@@ -735,7 +746,7 @@ 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);
}
@@ -772,7 +783,7 @@ FileWatchProc(
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
Tcl_Time blockTime = { 0, 0 };
/*
@@ -810,14 +821,14 @@ FileGetHandleProc(
int direction, /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr) /* Where to store the handle. */
{
- FileInfo *infoPtr = instanceData;
+ 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;
}
/*
@@ -855,12 +866,12 @@ TclpOpenFileChannel(
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
- nativeName = Tcl_FSGetNativePath(pathPtr);
+ 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;
}
@@ -908,39 +919,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);
+ 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;
@@ -969,10 +981,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) {
+ if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
@@ -985,9 +998,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.
@@ -996,7 +1009,7 @@ TclpOpenFileChannel(
handle = TclWinSerialOpen(handle, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
- if (interp != (Tcl_Interp *) NULL) {
+ if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't reopen serial \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
@@ -1011,10 +1024,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);
@@ -1023,7 +1036,8 @@ TclpOpenFileChannel(
case FILE_TYPE_DISK:
case FILE_TYPE_UNKNOWN:
channel = TclWinOpenFileChannel(handle, channelName,
- channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0);
+ channelPermissions,
+ TEST_FLAG(mode, O_APPEND) ? FILE_APPEND : 0);
break;
default:
@@ -1088,10 +1102,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);
@@ -1363,7 +1377,7 @@ TclWinOpenFileChannel(
}
}
- infoPtr = ckalloc(sizeof(FileInfo));
+ infoPtr = (FileInfo *)ckalloc(sizeof(FileInfo));
/*
* TIP #218. Removed the code inserting the new structure into the global
@@ -1377,7 +1391,7 @@ TclWinOpenFileChannel(
infoPtr->flags = appendMode;
infoPtr->handle = handle;
infoPtr->dirty = 0;
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
infoPtr, permissions);
@@ -1454,7 +1468,7 @@ FileThreadActionProc(
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- FileInfo *infoPtr = instanceData;
+ FileInfo *infoPtr = (FileInfo *)instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
@@ -1538,10 +1552,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]+
@@ -1563,12 +1578,12 @@ NativeIsComPort(
* 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;
@@ -1580,11 +1595,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 1293ebe..3b8753b 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -31,8 +31,10 @@ TCL_DECLARE_MUTEX(consoleMutex)
* Bit masks used in the flags field of the ConsoleInfo structure below.
*/
-#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */
-#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */
+#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */
+#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */
+#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */
+#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */
/*
* Bit masks used in the sharedFlags field of the ConsoleInfo structure below.
@@ -49,7 +51,7 @@ TCL_DECLARE_MUTEX(consoleMutex)
* threads.
*/
-typedef struct ConsoleThreadInfo {
+typedef struct {
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
@@ -102,11 +104,12 @@ typedef struct ConsoleInfo {
* readable object. */
int bytesRead; /* Number of bytes in the buffer. */
int offset; /* Number of bytes read out of the buffer. */
+ DWORD initMode; /* Initial console mode. */
char buffer[CONSOLE_BUFFER_SIZE];
/* Data consumed by reader thread. */
} ConsoleInfo;
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* The following pointer refers to the head of the list of consoles that
* are being watched for file events.
@@ -122,7 +125,7 @@ static Tcl_ThreadDataKey dataKey;
* console events are generated.
*/
-typedef struct ConsoleEvent {
+typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
ConsoleInfo *infoPtr; /* Pointer to console info structure. Note
@@ -139,19 +142,23 @@ 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 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 DWORD WINAPI ConsoleReaderThread(LPVOID arg);
+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 DWORD WINAPI ConsoleWriterThread(LPVOID arg);
@@ -173,15 +180,15 @@ static BOOL WriteConsoleBytes(HANDLE hConsole,
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- ConsoleCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
- NULL, /* Set option proc. */
- NULL, /* Get option proc. */
+ ConsoleSetOptionProc, /* Set option proc. */
+ ConsoleGetOptionProc, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
- ConsoleClose2Proc, /* close2proc. */
+ ConsoleCloseProc, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
NULL, /* Flush proc. */
NULL, /* Handler proc. */
@@ -310,7 +317,7 @@ ConsoleInit(void)
static void
ConsoleExitHandler(
- ClientData clientData) /* Old window proc. */
+ TCL_UNUSED(ClientData))
{
Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
}
@@ -334,7 +341,7 @@ ConsoleExitHandler(
static void
ProcExitHandler(
- ClientData clientData) /* Old window proc. */
+ TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&consoleMutex);
initialized = 0;
@@ -360,7 +367,7 @@ ProcExitHandler(
void
ConsoleSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
@@ -414,7 +421,7 @@ ConsoleSetupProc(
static void
ConsoleCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
@@ -455,7 +462,7 @@ ConsoleCheckProc(
}
if (needEvent) {
- ConsoleEvent *evPtr = ckalloc(sizeof(ConsoleEvent));
+ ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent));
infoPtr->flags |= CONSOLE_PENDING;
evPtr->header.proc = ConsoleEventProc;
@@ -487,7 +494,7 @@ ConsoleBlockModeProc(
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- ConsoleInfo *infoPtr = instanceData;
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
/*
* Consoles on Windows can not be switched between blocking and
@@ -508,7 +515,7 @@ ConsoleBlockModeProc(
/*
*----------------------------------------------------------------------
*
- * ConsoleCloseProc/ConsoleClose2Proc --
+ * ConsoleCloseProc --
*
* Closes a console based IO channel.
*
@@ -524,13 +531,18 @@ ConsoleBlockModeProc(
static int
ConsoleCloseProc(
ClientData instanceData, /* Pointer to ConsoleInfo structure. */
- Tcl_Interp *interp) /* For error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
{
- ConsoleInfo *consolePtr = instanceData;
+ ConsoleInfo *consolePtr = (ConsoleInfo *)instanceData;
int errorCode = 0;
ConsoleInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ 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
@@ -569,6 +581,17 @@ ConsoleCloseProc(
consolePtr->validMask &= ~TCL_WRITABLE;
/*
+ * If the user has been tinkering with the mode, reset it now. We ignore
+ * any errors from this; we're quite possibly about to close or exit
+ * anyway.
+ */
+
+ if ((consolePtr->flags & CONSOLE_READ_OPS) &&
+ (consolePtr->flags & CONSOLE_RESET)) {
+ SetConsoleMode(consolePtr->handle, consolePtr->initMode);
+ }
+
+ /*
* 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.
@@ -590,7 +613,7 @@ ConsoleCloseProc(
* Remove the file from the list of watched files.
*/
- for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr;
+ for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr;
infoPtr != NULL;
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
if (infoPtr == (ConsoleInfo *) consolePtr) {
@@ -606,18 +629,6 @@ ConsoleCloseProc(
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;
-}
/*
*----------------------------------------------------------------------
@@ -645,7 +656,7 @@ ConsoleInputProc(
* buffer? */
int *errorCode) /* Where to store error code. */
{
- ConsoleInfo *infoPtr = instanceData;
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
DWORD count, bytesRead = 0;
int result;
@@ -672,11 +683,11 @@ ConsoleInputProc(
*/
if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize);
+ memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
bytesRead = bufSize;
infoPtr->offset += bufSize;
} else {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize);
+ memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
bytesRead = infoPtr->bytesRead - infoPtr->offset;
/*
@@ -737,7 +748,7 @@ ConsoleOutputProc(
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
- ConsoleInfo *infoPtr = instanceData;
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
ConsoleThreadInfo *threadInfo = &infoPtr->writer;
DWORD bytesWritten, timeout;
@@ -781,9 +792,9 @@ ConsoleOutputProc(
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc(toWrite);
+ infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
- memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
+ memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(threadInfo->readyEvent);
TclPipeThreadSignal(&threadInfo->TI);
@@ -922,7 +933,7 @@ ConsoleWatchProc(
* TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
- ConsoleInfo *infoPtr = instanceData;
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int oldMask = infoPtr->watchMask;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -977,10 +988,10 @@ 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 = instanceData;
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
*handlePtr = infoPtr->handle;
return TCL_OK;
@@ -1014,7 +1025,7 @@ WaitForRead(
* or not. */
{
DWORD timeout, count;
- HANDLE *handle = infoPtr->handle;
+ HANDLE *handle = (HANDLE *)infoPtr->handle;
ConsoleThreadInfo *threadInfo = &infoPtr->reader;
INPUT_RECORD input;
@@ -1130,7 +1141,7 @@ ConsoleReaderThread(
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
- handle = infoPtr->handle;
+ handle = (HANDLE *)infoPtr->handle;
threadInfo = &infoPtr->reader;
}
@@ -1228,7 +1239,7 @@ ConsoleWriterThread(
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
- handle = infoPtr->handle;
+ handle = (HANDLE *)infoPtr->handle;
threadInfo = &infoPtr->writer;
}
@@ -1315,7 +1326,7 @@ TclWinOpenConsoleChannel(
* See if a channel with this handle already exists.
*/
- infoPtr = ckalloc(sizeof(ConsoleInfo));
+ infoPtr = (ConsoleInfo *)ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
@@ -1332,7 +1343,7 @@ TclWinOpenConsoleChannel(
* for instance).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
infoPtr, permissions);
@@ -1344,7 +1355,9 @@ TclWinOpenConsoleChannel(
* we only want to catch when complete lines are ready for reading.
*/
- GetConsoleMode(infoPtr->handle, &modes);
+ infoPtr->flags |= CONSOLE_READ_OPS;
+ GetConsoleMode(infoPtr->handle, &infoPtr->initMode);
+ modes = infoPtr->initMode;
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
@@ -1372,7 +1385,7 @@ TclWinOpenConsoleChannel(
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "utf-16");
return infoPtr->channel;
}
@@ -1397,7 +1410,7 @@ ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
- ConsoleInfo *infoPtr = instanceData;
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
/*
* We do not access firstConsolePtr in the thread structures. This is not
@@ -1427,6 +1440,213 @@ ConsoleThreadActionProc(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
+ int len = strlen(optionName);
+ int vlen = strlen(value);
+
+ /*
+ * Option -inputmode normal|password|raw
+ */
+
+ if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) &&
+ (strncmp(optionName, "-inputmode", len) == 0)) {
+ DWORD mode;
+
+ if (GetConsoleMode(infoPtr->handle, &mode) == 0) {
+ TclWinConvertError(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;
+ } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) {
+ mode |= ENABLE_LINE_INPUT;
+ mode &= ~ENABLE_ECHO_INPUT;
+ } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) {
+ mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT);
+ } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) {
+ /*
+ * Reset to the initial mode, whatever that is.
+ */
+
+ mode = infoPtr->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(infoPtr->handle, mode) == 0) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't set console mode: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * If we've changed the mode from default, schedule a reset later.
+ */
+
+ if (mode == infoPtr->initMode) {
+ infoPtr->flags &= ~CONSOLE_RESET;
+ } else {
+ infoPtr->flags |= CONSOLE_RESET;
+ }
+ return TCL_OK;
+ }
+
+ if (infoPtr->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). */
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *)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 (infoPtr->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(infoPtr->handle, &mode) == 0) {
+ TclWinConvertError(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");
+ }
+ }
+ }
+
+ /*
+ * 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)) {
+ CONSOLE_SCREEN_BUFFER_INFO consoleInfo;
+
+ valid = 1;
+ if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't read console size: %s",
+ Tcl_PosixError(interp)));
+ }
+ return TCL_ERROR;
+ }
+ sprintf(buf, "%d",
+ consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ sprintf(buf, "%d",
+ consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+
+ if (valid) {
+ return TCL_OK;
+ }
+ if (infoPtr->flags & CONSOLE_READ_OPS) {
+ return Tcl_BadChannelOption(interp, optionName, "inputmode winsize");
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "");
+ }
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/win/tclWinError.c b/win/tclWinError.c
index fea4b0f..18f290f 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -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 357f0a1..6750d29 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -145,8 +145,8 @@ TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
- return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
- 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"
@@ -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, -1, &srcString);
+ dst = Tcl_WCharToUtfDString(nativeDstPath, -1, &dstString);
/*
* Check whether the destination path is actually inside the
@@ -337,7 +339,7 @@ DoRenameFile(
* character is either end-of-string or a directory separator
*/
- if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0)
+ if ((strncmp(src, dst, Tcl_DStringLength(&srcString))==0)
&& (dst[Tcl_DStringLength(&srcString)] == '\\'
|| dst[Tcl_DStringLength(&srcString)] == '/'
|| dst[Tcl_DStringLength(&srcString)] == '\0')) {
@@ -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.
*/
@@ -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.
*/
@@ -534,8 +536,8 @@ TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
- return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
- Tcl_FSGetNativePath(destPathPtr));
+ return DoCopyFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
+ (const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
@@ -749,7 +751,7 @@ TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
- const WCHAR *path = nativePath;
+ const WCHAR *path = (const WCHAR *)nativePath;
/*
* The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
@@ -854,7 +856,7 @@ int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
- return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
+ return DoCreateDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr));
}
static int
@@ -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(Tcl_GetString(normSrcPtr), -1, &srcString);
+ Tcl_UtfToWCharDString(Tcl_GetString(normDestPtr), -1, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
@@ -984,11 +988,12 @@ TclpObjRemoveDirectory(
if (normPtr == NULL) {
return TCL_ERROR;
}
- Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
+ Tcl_DStringInit(&native);
+ Tcl_UtfToWCharDString(Tcl_GetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
- ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds);
+ ret = DoRemoveJustDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
if (ret != TCL_OK) {
@@ -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, -1, 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 *)
@@ -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 == '.') {
@@ -1323,7 +1331,8 @@ TraverseWinTree(
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
- Tcl_WinTCharToUtf((TCHAR *)nativeErrfile, -1, errorPtr);
+ Tcl_DStringInit(errorPtr);
+ Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
@@ -1388,7 +1397,8 @@ TraversalCopy(
*/
if (errorPtr != NULL) {
- Tcl_WinTCharToUtf((TCHAR *)nativeDst, -1, errorPtr);
+ Tcl_DStringInit(errorPtr);
+ Tcl_WCharToUtfDString(nativeDst, -1, 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, -1, errorPtr);
}
return TCL_ERROR;
}
@@ -1506,7 +1517,7 @@ GetWinFileAttributes(
const WCHAR *nativeName;
int attr;
- nativeName = 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);
+ *attributePtrPtr = Tcl_NewWideIntObj(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, -1, &dsTemp);
Tcl_DStringFree(&ds);
/*
@@ -1833,7 +1843,7 @@ SetWinFileAttributes(
int yesNo, result;
const WCHAR *nativeName;
- nativeName = 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
@@ -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), -1, &base);
+ if (dirObj->bytes[dirObj->length - 1] != '\\') {
+ Tcl_UtfToWCharDString("\\", -1, &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), -1, &base);
+ } else {
+ Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base);
+ }
+ Tcl_UtfToWCharDString("_", -1, &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, -1, &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) {
+ TclWinConvertError(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), -1, &name);
+ Tcl_DStringFree(&base);
+ return TclDStringToObj(&name);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 752aa0c..d2777d7 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -634,10 +634,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;
@@ -875,6 +876,7 @@ TclpFindExecutable(
*/
if (argv0 == NULL) {
+# undef Tcl_SetPanicProc
Tcl_SetPanicProc(tclWinDebugPanic);
}
@@ -934,9 +936,9 @@ TclpMatchInDirectory(
int len;
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
- const char *str = Tcl_GetStringFromObj(norm,&len);
+ const char *str = TclGetStringFromObj(norm, &len);
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
@@ -977,7 +979,7 @@ TclpMatchInDirectory(
* Verify that the specified path exists and is actually a directory.
*/
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
}
@@ -994,7 +996,7 @@ TclpMatchInDirectory(
*/
Tcl_DStringInit(&dsOrig);
- dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
+ dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
@@ -1022,7 +1024,8 @@ TclpMatchInDirectory(
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
- native = (WCHAR *)Tcl_WinUtfToTChar(dirName, -1, &ds);
+ Tcl_DStringInit(&ds);
+ native = Tcl_UtfToWCharDString(dirName, -1, &ds);
if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
handle = FindFirstFileW(native, &data);
} else {
@@ -1095,7 +1098,8 @@ TclpMatchInDirectory(
native = data.cFileName;
attr = data.dwFileAttributes;
- utfname = Tcl_WinTCharToUtf((TCHAR *)native, -1, &ds);
+ Tcl_DStringInit(&ds);
+ utfname = Tcl_WCharToUtfDString(native, -1, &ds);
if (!matchSpecialDots) {
/*
@@ -1469,13 +1473,15 @@ TclpGetUserHome(
}
Tcl_DStringFree(&ds);
} else {
- wName = (WCHAR *)Tcl_WinUtfToTChar(domain + 1, -1, &ds);
+ Tcl_DStringInit(&ds);
+ wName = Tcl_UtfToWCharDString(domain + 1, -1, &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
@@ -1495,7 +1501,7 @@ TclpGetUserHome(
if (rc != 0) {
break;
}
- domain = INT2PTR(-1); /* repeat once */
+ domain = (const char *)INT2PTR(-1); /* repeat once */
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
@@ -1503,7 +1509,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 {
/*
* User exists but has no home dir. Return
@@ -1511,7 +1517,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);
}
@@ -1870,7 +1876,7 @@ static int
NativeIsExec(
const WCHAR *path)
{
- size_t len = wcslen(path);
+ int len = wcslen(path);
if (len < 5) {
return 0;
@@ -1914,7 +1920,7 @@ TclpObjChdir(
int result;
const WCHAR *nativePath;
- nativePath = Tcl_FSGetNativePath(pathPtr);
+ nativePath = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
@@ -1979,7 +1985,8 @@ TclpGetCwd(
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
- Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
+ Tcl_DStringInit(bufferPtr);
+ Tcl_WCharToUtfDString(native, -1, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
@@ -2006,7 +2013,7 @@ TclpObjStat(
TclWinFlushDirtyChannels();
- return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0);
+ return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}
/*
@@ -2187,7 +2194,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, -1, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
@@ -2199,7 +2207,7 @@ NativeDev(
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
- * Add terminating backslash to fullpath or GetVolumeInformation()
+ * Add terminating backslash to fullpath or GetVolumeInformationW()
* won't work.
*/
@@ -2208,7 +2216,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);
@@ -2375,7 +2384,7 @@ TclpObjAccess(
Tcl_Obj *pathPtr,
int mode)
{
- return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode);
+ return NativeAccess((const WCHAR *)Tcl_FSGetNativePath(pathPtr), mode);
}
int
@@ -2391,7 +2400,7 @@ TclpObjLstat(
TclWinFlushDirtyChannels();
- return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1);
+ return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}
#ifdef S_IFLNK
@@ -2404,14 +2413,14 @@ TclpObjLink(
if (toPtr != NULL) {
int res;
const WCHAR *LinkTarget;
- const WCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr);
+ const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);
if (normalizedToPtr == NULL) {
return NULL;
}
- LinkTarget = Tcl_FSGetNativePath(normalizedToPtr);
+ LinkTarget = (const WCHAR *)Tcl_FSGetNativePath(normalizedToPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
@@ -2423,7 +2432,7 @@ TclpObjLink(
return NULL;
}
} else {
- const WCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr);
+ const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL) {
return NULL;
@@ -2472,13 +2481,13 @@ TclpFilesystemPathType(
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
- found = GetVolumeInformationW(Tcl_FSGetNativePath(pathPtr),
+ found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(pathPtr),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
} else {
Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
Tcl_IncrRefCount(driveName);
- found = GetVolumeInformationW(Tcl_FSGetNativePath(driveName),
+ found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(driveName),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
Tcl_DecrRefCount(driveName);
}
@@ -2488,7 +2497,8 @@ TclpFilesystemPathType(
} else {
Tcl_DString ds;
- Tcl_WinTCharToUtf((TCHAR *)volType, -1, &ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString(volType, -1, &ds);
return TclDStringToObj(&ds);
}
#undef VOL_BUF_SIZE
@@ -2531,7 +2541,7 @@ TclpFilesystemPathType(
int
TclpObjNormalizePath(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize */
int nextCheckpoint) /* offset to start at in pathPtr */
@@ -2559,7 +2569,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,
@@ -2761,11 +2774,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.
*/
@@ -2792,8 +2808,9 @@ 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) {
/*
@@ -2807,7 +2824,7 @@ TclpObjNormalizePath(
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
- path = Tcl_GetStringFromObj(tmpPathPtr, &len);
+ path = TclGetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
@@ -2892,8 +2909,7 @@ TclWinVolumeRelativeNormalize(
*/
int cwdLen;
- const char *drive =
- Tcl_GetStringFromObj(useThisCwd, &cwdLen);
+ const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
if (drive_cur >= 'a') {
@@ -2969,7 +2985,8 @@ TclpNativeToNormalized(
int len;
char *copy, *p;
- Tcl_WinTCharToUtf((TCHAR *) clientData, -1, &ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString((const WCHAR *) clientData, -1, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
@@ -3097,7 +3114,7 @@ TclNativeCreateNativeRep(
* Overallocate 6 chars, making some room for extended paths
*/
- wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR));
+ wp = nativePathPtr = (WCHAR *)ckalloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
goto done;
}
@@ -3195,7 +3212,7 @@ TclNativeDupInternalRep(
len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
- copy = ckalloc(len);
+ copy = (char *)ckalloc(len);
memcpy(copy, clientData, len);
return copy;
}
@@ -3232,7 +3249,7 @@ TclpUtime(
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
attr = GetFileAttributesW(native);
@@ -3283,7 +3300,7 @@ TclWinFileOwned(
DWORD bufsz;
int owned = 0;
- native = Tcl_FSGetNativePath(pathPtr);
+ native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
@@ -3311,7 +3328,7 @@ TclWinFileOwned(
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
- buf = ckalloc(bufsz);
+ buf = (LPBYTE)ckalloc(bufsz);
if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
}
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index b1dd0f3..420e324 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -106,12 +106,6 @@ static ProcessGlobalValue sourceLibraryDir =
{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
-
-#if TCL_UTF_MAX < 4
-static void ToUtf(const WCHAR *wSrc, char *dst);
-#else
-#define ToUtf(wSrc, dst) WideCharToMultiByte(CP_UTF8, 0, wSrc, -1, dst, MAX_PATH * TCL_UTF_MAX, NULL, NULL)
-#endif
/*
*---------------------------------------------------------------------------
@@ -186,13 +180,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;
pathPtr = Tcl_NewObj();
@@ -228,9 +223,10 @@ TclpInitLibraryPath(
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
- bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
- *valuePtr = (char *)ckalloc((*lengthPtr) + 1);
- memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
+ bytes = TclGetStringFromObj(pathPtr, &length);
+ *lengthPtr = length++;
+ *valuePtr = (char *)ckalloc(length);
+ memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
@@ -289,12 +285,8 @@ AppendEnvironment(
* this is a unicode string.
*/
- if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
- buf[0] = '\0';
- GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
- } else {
- ToUtf(wBuf, buf);
- }
+ GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
+ WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);
if (buf[0] != '\0') {
objPtr = Tcl_NewStringObj(buf, -1);
@@ -348,7 +340,7 @@ AppendEnvironment(
static void
InitializeDefaultLibraryDir(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
@@ -356,11 +348,8 @@ InitializeDefaultLibraryDir(
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
- if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
- GetModuleFileNameA(hModule, name, MAX_PATH);
- } else {
- ToUtf(wName, name);
- }
+ GetModuleFileNameW(hModule, wName, MAX_PATH);
+ WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL);
end = strrchr(name, '\\');
*end = '\0';
@@ -399,19 +388,16 @@ InitializeDefaultLibraryDir(
static void
InitializeSourceLibraryDir(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
- char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
+ char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
- if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
- GetModuleFileNameA(hModule, name, MAX_PATH);
- } else {
- ToUtf(wName, name);
- }
+ GetModuleFileNameW(hModule, wName, MAX_PATH);
+ WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL);
end = strrchr(name, '\\');
*end = '\0';
@@ -432,36 +418,6 @@ InitializeSourceLibraryDir(
/*
*---------------------------------------------------------------------------
*
- * ToUtf --
- *
- * Convert a wchar string to a UTF string.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-#if TCL_UTF_MAX < 4
-static void
-ToUtf(
- const WCHAR *wSrc,
- char *dst)
-{
- while (*wSrc != '\0') {
- dst += Tcl_UniCharToUtf(*wSrc, dst);
- wSrc++;
- }
- *dst = '\0';
-}
-#endif
-
-/*
- *---------------------------------------------------------------------------
- *
* TclpSetInitialEncodings --
*
* Based on the locale, determine the encoding of the operating system
@@ -493,12 +449,6 @@ TclpSetInitialEncodings(void)
Tcl_DStringFree(&encodingName);
}
-void TclWinSetInterfaces(
- int dummy) /* Not used. */
-{
- (void)dummy;
-}
-
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
@@ -531,8 +481,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);
}
@@ -674,6 +624,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
@@ -708,7 +661,8 @@ TclpFindVariable(
* after the equal sign.
*/
- envUpper = Tcl_WinTCharToUtf((TCHAR *)env, -1, &envString);
+ Tcl_DStringInit(&envString);
+ envUpper = Tcl_WCharToUtfDString(env, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index 5f532bc..3b31d8a 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -41,25 +41,6 @@ typedef struct 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
-
-#ifdef _WIN64
-# define TCL_I_MODIFIER "I"
-#else
-# define TCL_I_MODIFIER ""
-#endif
-
-/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
@@ -82,13 +63,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);
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 1d64d18..1a74618 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -61,13 +61,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 +95,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(Tcl_GetString(pathPtr), -1, &ds);
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
@@ -281,14 +281,9 @@ UnloadFile(
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. */
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(Tcl_DString *))
{
- (void)fileName;
- (void)bufPtr;
-
return 0;
}
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 2542476..2ab4efa 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.c
@@ -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.
@@ -83,32 +83,40 @@ Tcl_InitNotifier(void)
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- WNDCLASSW windowClass;
+
+ TclpMasterLock();
+ if (!initialized) {
+ initialized = 1;
+ InitializeCriticalSection(&notifierMutex);
+ }
+ TclpMasterUnlock();
/*
* Register Notifier window class if this is the first thread to use
* this module.
*/
- Tcl_MutexLock(&notifierMutex);
+ EnterCriticalSection(&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)) {
+ 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("Unable to register TclNotifier window class");
}
}
notifierCount++;
- Tcl_MutexUnlock(&notifierMutex);
+ LeaveCriticalSection(&notifierMutex);
tsdPtr->pending = 0;
tsdPtr->timerActive = 0;
@@ -183,12 +191,14 @@ Tcl_FinalizeNotifier(
* notifier window class.
*/
- Tcl_MutexLock(&notifierMutex);
- notifierCount--;
- if (notifierCount == 0) {
- UnregisterClassW(classname, TclWinGetTclInstance());
+ EnterCriticalSection(&notifierMutex);
+ if (notifierCount) {
+ notifierCount--;
+ if (notifierCount == 0) {
+ UnregisterClassW(className, TclWinGetTclInstance());
+ }
}
- Tcl_MutexUnlock(&notifierMutex);
+ LeaveCriticalSection(&notifierMutex);
}
}
@@ -299,11 +309,10 @@ Tcl_SetTimer(
timeout = 1;
}
}
- tsdPtr->timeout = timeout;
if (timeout != 0) {
tsdPtr->timerActive = 1;
SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
- (unsigned long) tsdPtr->timeout, NULL);
+ timeout, NULL);
} else {
tsdPtr->timerActive = 0;
KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
@@ -350,7 +359,7 @@ Tcl_ServiceModeHook(
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
- tsdPtr->hwnd = CreateWindowW(classname, classname,
+ tsdPtr->hwnd = CreateWindowW(className, className,
WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(),
NULL);
diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c
new file mode 100644
index 0000000..fbd3e46
--- /dev/null
+++ b/win/tclWinPanic.c
@@ -0,0 +1,88 @@
+/*
+ * tclWinPanic.c --
+ *
+ * Contains the Windows-specific command-line panic proc.
+ *
+ * Copyright (c) 2013 by 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, wcslen(msgString), &dummy, 0);
+ } else {
+ buf[0] = '\xEF'; buf[1] = '\xBB'; buf[2] = '\xBF'; /* UTF-8 bom */
+ WriteFile(handle, buf, 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 04c371e..14270f8 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -310,7 +310,7 @@ TclpFinalizePipes(void)
void
PipeSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
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(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
@@ -402,7 +402,7 @@ PipeCheckProc(
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
- evPtr = ckalloc(sizeof(PipeEvent));
+ evPtr = (PipeEvent *)ckalloc(sizeof(PipeEvent));
evPtr->header.proc = PipeEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -433,7 +433,7 @@ TclWinMakeFile(
{
WinFile *filePtr;
- filePtr = ckalloc(sizeof(WinFile));
+ filePtr = (WinFile *)ckalloc(sizeof(WinFile));
filePtr->type = WIN_FILE;
filePtr->handle = handle;
@@ -577,7 +577,8 @@ TclpOpenFile(
break;
}
- nativePath = (WCHAR *)Tcl_WinUtfToTChar(path, -1, &ds);
+ Tcl_DStringInit(&ds);
+ nativePath = Tcl_UtfToWCharDString(path, -1, &ds);
/*
* If the file is not being created, use the existing file attributes.
@@ -868,7 +869,7 @@ 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;
}
@@ -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();
@@ -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;
}
/*
@@ -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,7 +1278,7 @@ 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.
*/
@@ -1307,7 +1291,8 @@ ApplicationType(
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_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, -1, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
@@ -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, -1, &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.
*
@@ -1744,7 +1731,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);
}
@@ -1775,7 +1763,7 @@ TclpCreateCommandChannel(
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
- PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo));
+ PipeInfo *infoPtr = (PipeInfo *)ckalloc(sizeof(PipeInfo));
PipeInit();
@@ -1834,7 +1822,7 @@ TclpCreateCommandChannel(
* unique, in case channels share handles (stdin/stdout).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
infoPtr, infoPtr->validMask);
@@ -1868,7 +1856,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;
@@ -1929,7 +1917,7 @@ TclGetAndDetachPids(
return;
}
- pipePtr = Tcl_GetChannelInstanceData(chan);
+ pipePtr = (PipeInfo *)Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj,
@@ -2315,9 +2303,9 @@ PipeOutputProc(
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc(toWrite);
+ infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
- memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
+ memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
TclPipeThreadSignal(&infoPtr->writeTI);
@@ -2577,7 +2565,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;
}
@@ -2723,7 +2711,7 @@ TclWinAddProcess(
void *hProcess, /* Handle to process */
unsigned long id) /* Global process identifier */
{
- ProcInfo *procPtr = ckalloc(sizeof(ProcInfo));
+ ProcInfo *procPtr = (ProcInfo*)ckalloc(sizeof(ProcInfo));
PipeInit();
@@ -2754,7 +2742,7 @@ TclWinAddProcess(
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. */
@@ -2823,7 +2811,7 @@ WaitForRead(
* or not. */
{
DWORD timeout, count;
- HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
+ HANDLE *handle = (HANDLE *)((WinFile *) infoPtr->readFile)->handle;
while (1) {
/*
@@ -3200,9 +3188,9 @@ 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];
@@ -3223,15 +3211,16 @@ 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);
} else {
const WCHAR *baseStr = L"TCL";
- int length = 3 * sizeof(WCHAR);
+ length = 3 * sizeof(WCHAR);
memcpy(namePtr, baseStr, length);
namePtr += length;
@@ -3245,7 +3234,8 @@ TclpOpenTemporaryFile(
sprintf(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);
@@ -3295,9 +3285,9 @@ TclPipeThreadCreateTI(
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
- pipeTI = malloc(sizeof(TclPipeThreadInfo));
+ pipeTI = (TclPipeThreadInfo *)malloc(sizeof(TclPipeThreadInfo));
#else
- pipeTI = ckalloc(sizeof(TclPipeThreadInfo));
+ pipeTI = (TclPipeThreadInfo *)ckalloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 5aa02f0..1aaf21d 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -18,6 +18,10 @@
/* 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.
@@ -52,15 +56,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.
*/
@@ -95,6 +90,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
@@ -557,7 +557,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/tclWinSerial.c b/win/tclWinSerial.c
index aeebb56..328fbad 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -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;
@@ -524,7 +535,7 @@ SerialCheckProc(
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
- evPtr = ckalloc(sizeof(SerialEvent));
+ evPtr = (SerialEvent *)ckalloc(sizeof(SerialEvent));
evPtr->header.proc = SerialEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -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);
@@ -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;
-}
/*
*----------------------------------------------------------------------
@@ -1036,9 +1038,9 @@ SerialOutputProc(
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc(toWrite);
+ infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
- memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
+ memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->evWritable);
TclPipeThreadSignal(&infoPtr->writeTI);
@@ -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;
}
@@ -1435,7 +1455,7 @@ TclWinOpenSerialChannel(
SerialInit();
- infoPtr = ckalloc(sizeof(SerialInfo));
+ infoPtr = (SerialInfo *)ckalloc(sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->validMask = permissions;
@@ -1456,7 +1476,7 @@ TclWinOpenSerialChannel(
* are shared between multiple channels (stdin/stdout).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
infoPtr, permissions);
@@ -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, -1, &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", -1));
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;
@@ -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;
@@ -1952,7 +1999,8 @@ 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) {
@@ -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
*/
@@ -2102,9 +2171,9 @@ SerialGetOptionProc(
}
return TCL_ERROR;
}
- sprintf(buf, "%c", dcb.XonChar);
+ buf[Tcl_UniCharToUtf(UCHAR(dcb.XonChar), buf)] = '\0';
Tcl_DStringAppendElement(dsPtr, buf);
- sprintf(buf, "%c", dcb.XoffChar);
+ buf[Tcl_UniCharToUtf(UCHAR(dcb.XoffChar), buf)] = '\0';
Tcl_DStringAppendElement(dsPtr, buf);
}
if (len == 0) {
@@ -2188,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 fdb7e12..48b3cee 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -62,15 +62,6 @@
#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.
@@ -78,6 +69,7 @@
#define SET_BITS(var, bits) ((var) |= (bits))
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
+#define GOT_BITS(var, bits) (((var) & (bits)) != 0)
/* "sock" + a pointer in hex + \0 */
#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1)
@@ -90,7 +82,7 @@
*/
static int initialized = 0;
-static const WCHAR classname[] = L"TclSocket";
+static const WCHAR className[] = L"TclSocket";
TCL_DECLARE_MUTEX(socketMutex)
/*
@@ -133,6 +125,8 @@ typedef struct TcpFdList {
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
+ int testFlags; /* bit field for tests. Is set by testsocket
+ * test procedure */
struct TcpFdList *sockets; /* Windows SOCKET handle. */
int flags; /* Bit field comprised of the flags described
* below. */
@@ -193,6 +187,15 @@ struct TcpState {
#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */
/*
+ * These bits may be ORed together into the "testFlags" field of a TcpState
+ * structure.
+ */
+
+#define TCP_ASYNC_TEST_MODE (1<<0) /* 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.
*/
@@ -277,7 +280,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. */
@@ -301,22 +308,39 @@ static const Tcl_ChannelType tcpChannelType = {
static TclInitProcessGlobalValueProc InitializeHostName;
static ProcessGlobalValue hostName =
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
+
+/*
+ * Simple wrapper round the SendMessage syscall.
+ */
+
+#define SendSelectMessage(tsdPtr, message, payload) \
+ SendMessageW((tsdPtr)->hwnd, SOCKET_SELECT, \
+ (WPARAM) (message), (LPARAM) (payload))
+
/*
* Address print debug functions
*/
#if 0
-void printaddrinfo(struct addrinfo *ai, char *prefix)
+void
+printaddrinfo(
+ struct addrinfo *ai,
+ char *prefix)
{
char host[NI_MAXHOST], port[NI_MAXSERV];
+
getnameinfo(ai->ai_addr, ai->ai_addrlen,
- host, sizeof(host),
- port, sizeof(port),
- NI_NUMERICHOST|NI_NUMERICSERV);
+ host, sizeof(host), port, sizeof(port),
+ NI_NUMERICHOST|NI_NUMERICSERV);
}
-void printaddrinfolist(struct addrinfo *addrlist, char *prefix)
+
+void
+printaddrinfolist(
+ struct addrinfo *addrlist,
+ char *prefix)
{
struct addrinfo *ai;
+
for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
printaddrinfo(ai, prefix);
}
@@ -340,22 +364,22 @@ void printaddrinfolist(struct addrinfo *addrlist, char *prefix)
void
InitializeHostName(
char **valuePtr,
- int *lengthPtr,
+ unsigned int *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, -1, &ds));
} else {
- Tcl_DStringInit(&ds);
if (TclpHasSockets(NULL) == TCL_OK) {
/*
* The buffer size of 256 is recommended by the MSDN page that
@@ -377,8 +401,8 @@ InitializeHostName(
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
- *valuePtr = ckalloc((*lengthPtr) + 1);
- memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1);
+ *valuePtr = (char *)ckalloc(*lengthPtr + 1);
+ memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1);
Tcl_DStringFree(&ds);
}
@@ -469,7 +493,7 @@ TclpHasSockets(
void
TclpFinalizeSockets(void)
{
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Careful! This is a finalizer!
@@ -529,12 +553,12 @@ TcpBlockModeProc(
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
- statePtr->flags |= TCP_NONBLOCKING;
+ SET_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
- statePtr->flags &= ~(TCP_NONBLOCKING);
+ CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
}
return 0;
}
@@ -544,29 +568,28 @@ TcpBlockModeProc(
*
* WaitForConnect --
*
- * Check the state of an async connect process. If a connection
- * attempt terminated, process it, which may finalize it or may
- * start the next attempt. If a connect error occures, it is saved
- * in statePtr->connectError to be reported by 'fconfigure -error'.
+ * Check the state of an async connect process. If a connection attempt
+ * terminated, process it, which may finalize it or may start the next
+ * attempt. If a connect error occures, it is saved in
+ * statePtr->connectError to be reported by 'fconfigure -error'.
*
* There are two modes of operation, defined by errorCodePtr:
- * * non-NULL: Called by explicite read/write command. block if
- * socket is blocking.
+ * * non-NULL: Called by explicite read/write command. Block if socket
+ * is blocking.
* May return two error codes:
* * EWOULDBLOCK: if connect is still in progress
- * * ENOTCONN: if connect failed. This would be the error
- * message of a rect or sendto syscall so this is
- * emulated here.
- * * Null: Called by a backround operation. Do not block and
- * don't return any error code.
+ * * ENOTCONN: if connect failed. This would be the error message
+ * of a rect or sendto syscall so this is emulated here.
+ * * Null: Called by a backround operation. Do not block and don't
+ * return any error code.
*
* Results:
- * 0 if the connection has completed, -1 if still in progress
- * or there is an error.
+ * 0 if the connection has completed, -1 if still in progress or there is
+ * an error.
*
* Side effects:
- * Processes socket events off the system queue.
- * May process asynchroneous connect.
+ * Processes socket events off the system queue. May process
+ * asynchroneous connect.
*
*----------------------------------------------------------------------
*/
@@ -574,20 +597,19 @@ TcpBlockModeProc(
static int
WaitForConnect(
TcpState *statePtr, /* State of the socket. */
- int *errorCodePtr) /* Where to store errors?
- * A passed null-pointer activates background mode.
- */
+ int *errorCodePtr) /* Where to store errors? A passed
+ * null-pointer activates background mode. */
{
int result;
int oldMode;
ThreadSpecificData *tsdPtr;
/*
- * Check if an async connect failed already and error reporting is demanded,
- * return the error ENOTCONN
+ * Check if an async connect failed already and error reporting is
+ * demanded, return the error ENOTCONN.
*/
- if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) {
+ if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
*errorCodePtr = ENOTCONN;
return -1;
}
@@ -596,11 +618,26 @@ WaitForConnect(
* Check if an async connect is running. If not return ok
*/
- if (!(statePtr->flags & TCP_ASYNC_CONNECT)) {
+ if (!GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
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))
+ * - Call by the event queue (errorCodePtr == NULL)
+ */
+
+ if (GOT_BITS(statePtr->testFlags, 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.
*/
@@ -611,36 +648,51 @@ WaitForConnect(
*/
while (1) {
+ /*
+ * Get the statePtr lock.
+ */
- /* get statePtr lock */
- tsdPtr = TclThreadDataKeyGet(&dataKey);
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- /* Check for connect event */
- if (statePtr->readyEvents & FD_CONNECT) {
+ /*
+ * Check for connect event.
+ */
+
+ if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
+ /*
+ * Consume the connect event.
+ */
- /* Consume the connect event */
- statePtr->readyEvents &= ~(FD_CONNECT);
+ CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);
/*
- * For blocking sockets and foreground processing
- * disable async connect as we continue now synchoneously
+ * For blocking sockets and foreground processing, disable async
+ * connect as we continue now synchoneously.
*/
- if ( errorCodePtr != NULL &&
- ! (statePtr->flags & TCP_NONBLOCKING) ) {
+
+ if (errorCodePtr != NULL &&
+ !GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
}
- /* Free list lock */
+ /*
+ * Free list lock.
+ */
+
SetEvent(tsdPtr->socketListLock);
/*
- * Continue connect.
- * If switched to synchroneous connect, the connect is terminated.
+ * Continue connect. If switched to synchroneous connect, the
+ * connect is terminated.
*/
+
result = TcpConnect(NULL, statePtr);
- /* Restore event service mode */
+ /*
+ * Restore event service mode.
+ */
+
(void) Tcl_SetServiceMode(oldMode);
/*
@@ -649,10 +701,11 @@ WaitForConnect(
if (result == TCL_OK) {
/*
- * Check for async connect restart
- * (not possible for foreground blocking operation)
+ * Check for async connect restart (not possible for
+ * foreground blocking operation)
*/
- if ( statePtr->flags & TCP_ASYNC_PENDING ) {
+
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
if (errorCodePtr != NULL) {
*errorCodePtr = EWOULDBLOCK;
}
@@ -662,8 +715,8 @@ WaitForConnect(
}
/*
- * Connect finally failed.
- * For foreground operation return ENOTCONN.
+ * Connect finally failed. For foreground operation return
+ * ENOTCONN.
*/
if (errorCodePtr != NULL) {
@@ -672,7 +725,10 @@ WaitForConnect(
return -1;
}
- /* Free list lock */
+ /*
+ * Free list lock.
+ */
+
SetEvent(tsdPtr->socketListLock);
/*
@@ -680,7 +736,7 @@ WaitForConnect(
* event
*/
- if ( errorCodePtr == NULL ) {
+ if (errorCodePtr == NULL) {
return -1;
}
@@ -689,7 +745,7 @@ WaitForConnect(
* returns directly the error EWOULDBLOCK
*/
- if (statePtr->flags & TCP_NONBLOCKING) {
+ if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
*errorCodePtr = EWOULDBLOCK;
return -1;
}
@@ -729,10 +785,10 @@ TcpInputProc(
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
int bytesRead;
DWORD error;
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
@@ -752,7 +808,7 @@ TcpInputProc(
* socket stack after the first time EOF is detected.
*/
- if (statePtr->flags & SOCKET_EOF) {
+ if (GOT_BITS(statePtr->flags, SOCKET_EOF)) {
return 0;
}
@@ -775,18 +831,22 @@ TcpInputProc(
*/
while (1) {
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) statePtr);
- /* single fd operation: this proc is only called for a connected socket. */
+ SendSelectMessage(tsdPtr, UNSELECT, statePtr);
+
+ /*
+ * Single fd operation: this proc is only called for a connected
+ * socket.
+ */
+
bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0);
- statePtr->readyEvents &= ~(FD_READ);
+ CLEAR_BITS(statePtr->readyEvents, FD_READ);
/*
* Check for end-of-file condition or successful read.
*/
if (bytesRead == 0) {
- statePtr->flags |= SOCKET_EOF;
+ SET_BITS(statePtr->flags, SOCKET_EOF);
}
if (bytesRead != SOCKET_ERROR) {
break;
@@ -797,8 +857,8 @@ TcpInputProc(
* error and report an EOF.
*/
- if (statePtr->readyEvents & FD_CLOSE) {
- statePtr->flags |= SOCKET_EOF;
+ if (GOT_BITS(statePtr->readyEvents, FD_CLOSE)) {
+ SET_BITS(statePtr->flags, SOCKET_EOF);
bytesRead = 0;
break;
}
@@ -811,7 +871,7 @@ TcpInputProc(
*/
if (error == WSAECONNRESET) {
- statePtr->flags |= SOCKET_EOF;
+ SET_BITS(statePtr->flags, SOCKET_EOF);
bytesRead = 0;
break;
}
@@ -820,7 +880,8 @@ TcpInputProc(
* Check for error condition or underflow in non-blocking case.
*/
- if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) {
+ if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)
+ || (error != WSAEWOULDBLOCK)) {
TclWinConvertError(error);
*errorCodePtr = Tcl_GetErrno();
bytesRead = -1;
@@ -838,7 +899,7 @@ TcpInputProc(
}
}
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
return bytesRead;
}
@@ -867,10 +928,10 @@ TcpOutputProc(
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
int written;
DWORD error;
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
@@ -896,10 +957,13 @@ TcpOutputProc(
}
while (1) {
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) statePtr);
+ SendSelectMessage(tsdPtr, UNSELECT, statePtr);
+
+ /*
+ * Single fd operation: this proc is only called for a connected
+ * socket.
+ */
- /* single fd operation: this proc is only called for a connected socket. */
written = send(statePtr->sockets->fd, buf, toWrite, 0);
if (written != SOCKET_ERROR) {
/*
@@ -908,8 +972,9 @@ TcpOutputProc(
* until the condition changes.
*/
- if (statePtr->watchEvents & FD_WRITE) {
+ if (GOT_BITS(statePtr->watchEvents, FD_WRITE)) {
Tcl_Time blockTime = { 0, 0 };
+
Tcl_SetMaxBlockTime(&blockTime);
}
break;
@@ -924,8 +989,8 @@ TcpOutputProc(
error = WSAGetLastError();
if (error == WSAEWOULDBLOCK) {
- statePtr->readyEvents &= ~(FD_WRITE);
- if (statePtr->flags & TCP_NONBLOCKING) {
+ CLEAR_BITS(statePtr->readyEvents, FD_WRITE);
+ if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) {
*errorCodePtr = EWOULDBLOCK;
written = -1;
break;
@@ -948,7 +1013,7 @@ TcpOutputProc(
}
}
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
return written;
}
@@ -974,9 +1039,9 @@ TcpOutputProc(
static int
TcpCloseProc(
ClientData instanceData, /* The socket to close. */
- Tcl_Interp *interp) /* Unused. */
+ TCL_UNUSED(Tcl_Interp *))
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -994,10 +1059,10 @@ TcpCloseProc(
* background.
*/
- while ( statePtr->sockets != NULL ) {
+ while (statePtr->sockets != NULL) {
TcpFdList *thisfd = statePtr->sockets;
- statePtr->sockets = thisfd->next;
+ statePtr->sockets = thisfd->next;
if (closesocket(thisfd->fd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
@@ -1015,18 +1080,25 @@ TcpCloseProc(
/*
* Clear an eventual tsd info list pointer.
+ *
* This may be called, if an async socket connect fails or is closed
* between connect and thread action callback.
*/
+
if (tsdPtr->pendingTcpState != NULL
&& tsdPtr->pendingTcpState == statePtr) {
+ /*
+ * Get infoPtr lock, because this concerns the notifier thread.
+ */
- /* get infoPtr lock, because this concerns the notifier thread */
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
tsdPtr->pendingTcpState = NULL;
- /* Free list lock */
+ /*
+ * Free list lock.
+ */
+
SetEvent(tsdPtr->socketListLock);
}
@@ -1064,7 +1136,7 @@ TcpClose2Proc(
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
@@ -1076,8 +1148,11 @@ TcpClose2Proc(
return TcpCloseProc(instanceData, interp);
}
- /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
- * TCL_WRITABLE so this should never be called for a server socket. */
+ /*
+ * Single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
+ * TCL_WRITABLE so this should never be called for a server socket.
+ */
+
if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) {
TclWinConvertError((DWORD) WSAGetLastError());
readError = Tcl_GetErrno();
@@ -1110,11 +1185,13 @@ TcpSetOptionProc(
ClientData 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. */
+ TCL_UNUSED(const char *) /*value*/) /* New value for option. */
{
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
TcpState *statePtr = instanceData;
SOCKET sock;
+#else
+ (void)instanceData;
#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
/*
@@ -1132,7 +1209,7 @@ TcpSetOptionProc(
}
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
- #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list"
+#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")) {
@@ -1218,7 +1295,7 @@ TcpGetOptionProc(
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
char host[NI_MAXHOST], port[NI_MAXSERV];
SOCKET sock;
size_t len = 0;
@@ -1241,9 +1318,14 @@ TcpGetOptionProc(
/*
* Go one step in async connect
- * If any error is thrown save it as backround error to report eventually below
+ *
+ * If any error is thrown save it as backround error to report eventually
+ * below.
*/
- WaitForConnect(statePtr, NULL);
+
+ if (!GOT_BITS(statePtr->testFlags, TCP_ASYNC_TEST_MODE)) {
+ WaitForConnect(statePtr, NULL);
+ }
sock = statePtr->sockets->fd;
if (optionName != NULL) {
@@ -1252,31 +1334,26 @@ TcpGetOptionProc(
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
-
/*
- * Do not return any errors if async connect is running
- */
- if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) {
-
-
- if ( statePtr->flags & TCP_ASYNC_FAILED ) {
+ * Do not return any errors if async connect is running.
+ */
+ if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
/*
* In case of a failed async connect, eventually report the
- * connect error only once.
- * Do not report the system error, as this comes again and again.
+ * connect error only once. Do not report the system error,
+ * as this comes again and again.
*/
- if ( statePtr->connectError != 0 ) {
+ if (statePtr->connectError != 0) {
Tcl_DStringAppend(dsPtr,
Tcl_ErrnoMsg(statePtr->connectError), -1);
statePtr->connectError = 0;
}
-
} else {
-
/*
- * Report an eventual last error of the socket system
+ * Report an eventual last error of the socket system.
*/
int optlen;
@@ -1284,24 +1361,30 @@ TcpGetOptionProc(
DWORD err;
/*
- * Populater the err Variable with a possix error
+ * Populate the err variable with a POSIX error
*/
+
optlen = sizeof(int);
ret = getsockopt(sock, SOL_SOCKET, SO_ERROR,
(char *)&err, &optlen);
+
/*
- * The error was not returned directly but should be
- * taken from WSA
+ * The error was not returned directly but should be taken
+ * from WSA.
*/
+
if (ret == SOCKET_ERROR) {
err = WSAGetLastError();
}
+
/*
- * Return error message
+ * Return error message.
*/
+
if (err) {
TclWinConvertError(err);
- Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
+ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()),
+ -1);
}
}
}
@@ -1310,14 +1393,14 @@ TcpGetOptionProc(
if ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-connecting", len) == 0)) {
-
Tcl_DStringAppend(dsPtr,
- (statePtr->flags & TCP_ASYNC_PENDING)
+ GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)
? "1" : "0", -1);
return TCL_OK;
}
- if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
+ if (interp != NULL
+ && Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) {
reverseDNS = NI_NUMERICHOST;
}
@@ -1326,20 +1409,23 @@ TcpGetOptionProc(
address peername;
socklen_t size = sizeof(peername);
- if ( (statePtr->flags & TCP_ASYNC_PENDING) ) {
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* In async connect output an empty string
*/
+
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringAppendElement(dsPtr, "");
} else {
return TCL_OK;
}
- } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) {
+ } else if (getpeername(sock, (LPSOCKADDR) &(peername.sa),
+ &size) == 0) {
/*
* Peername fetch succeeded - output list
*/
+
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
@@ -1388,11 +1474,12 @@ TcpGetOptionProc(
Tcl_DStringAppendElement(dsPtr, "-sockname");
Tcl_DStringStartSublist(dsPtr);
}
- if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) {
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* In async connect output an empty string
*/
- found = 1;
+
+ found = 1;
} else {
for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
sock = fds->fd;
@@ -1406,9 +1493,11 @@ TcpGetOptionProc(
Tcl_DStringAppendElement(dsPtr, host);
/*
- * We don't want to resolve INADDR_ANY and sin6addr_any; they
- * can sometimes cause problems (and never have a name).
+ * We don't want to resolve INADDR_ANY and sin6addr_any;
+ * they can sometimes cause problems (and never have a
+ * name).
*/
+
flags |= NI_NUMERICSERV;
if (sockname.sa.sa_family == AF_INET) {
if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) {
@@ -1492,7 +1581,8 @@ TcpGetOptionProc(
return Tcl_BadChannelOption(interp, optionName,
"connecting peername sockname keepalive nagle");
#else
- return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname");
+ return Tcl_BadChannelOption(interp, optionName,
+ "connecting peername sockname");
#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
}
@@ -1524,7 +1614,7 @@ TcpWatchProc(
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
/*
* Update the watch events mask. Only if the socket is not a server
@@ -1533,11 +1623,11 @@ TcpWatchProc(
if (!statePtr->acceptProc) {
statePtr->watchEvents = 0;
- if (mask & TCL_READABLE) {
- statePtr->watchEvents |= (FD_READ|FD_CLOSE);
+ if (GOT_BITS(mask, TCL_READABLE)) {
+ SET_BITS(statePtr->watchEvents, FD_READ | FD_CLOSE);
}
- if (mask & TCL_WRITABLE) {
- statePtr->watchEvents |= (FD_WRITE|FD_CLOSE);
+ if (GOT_BITS(mask, TCL_WRITABLE)) {
+ SET_BITS(statePtr->watchEvents, FD_WRITE | FD_CLOSE);
}
/*
@@ -1574,10 +1664,10 @@ TcpWatchProc(
static int
TcpGetHandleProc(
ClientData instanceData, /* The socket state. */
- int direction, /* Not used. */
+ TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->sockets->fd);
return TCL_OK;
@@ -1627,25 +1717,24 @@ TcpConnect(
TcpState *statePtr)
{
DWORD error;
- /*
- * We are started with async connect and the connect notification
- * was not jet received
- */
- int async_connect = statePtr->flags & TCP_ASYNC_CONNECT;
- /* We were called by the event procedure and continue our loop */
- int async_callback = statePtr->flags & TCP_ASYNC_PENDING;
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
+ /* We are started with async connect and the
+ * connect notification was not yet
+ * received. */
+ int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
+ /* We were called by the event procedure and
+ * continue our loop. */
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
- statePtr->addr = statePtr->addr->ai_next) {
-
- for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL;
- statePtr->myaddr = statePtr->myaddr->ai_next) {
-
+ statePtr->addr = statePtr->addr->ai_next) {
+ for (statePtr->myaddr = statePtr->myaddrlist;
+ statePtr->myaddr != NULL;
+ statePtr->myaddr = statePtr->myaddr->ai_next) {
/*
* No need to try combinations of local and remote addresses
* of different families.
@@ -1659,25 +1748,37 @@ TcpConnect(
* Close the socket if it is still open from the last unsuccessful
* iteration.
*/
+
if (statePtr->sockets->fd != INVALID_SOCKET) {
closesocket(statePtr->sockets->fd);
}
- /* get statePtr lock */
+ /*
+ * Get statePtr lock.
+ */
+
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Reset last error from last try
*/
+
statePtr->notifierConnectError = 0;
Tcl_SetErrno(0);
- statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0);
+ statePtr->sockets->fd = socket(statePtr->myaddr->ai_family,
+ SOCK_STREAM, 0);
+
+ /*
+ * Free list lock.
+ */
- /* Free list lock */
SetEvent(tsdPtr->socketListLock);
- /* continue on socket creation error */
+ /*
+ * Continue on socket creation error.
+ */
+
if (statePtr->sockets->fd == INVALID_SOCKET) {
TclWinConvertError((DWORD) WSAGetLastError());
continue;
@@ -1688,31 +1789,39 @@ TcpConnect(
* processes by default. Turn off the inherit bit.
*/
- SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0);
+ SetHandleInformation((HANDLE) statePtr->sockets->fd,
+ HANDLE_FLAG_INHERIT, 0);
/*
* Set kernel space buffering
*/
- TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE);
+ TclSockMinimumBuffers((void *) statePtr->sockets->fd,
+ TCP_BUFFER_SIZE);
/*
* Try to bind to a local port.
*/
if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
- statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
+ statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
continue;
}
+
/*
* For asynchroneous connect set the socket in nonblocking mode
* and activate connect notification
*/
+
if (async_connect) {
TcpState *statePtr2;
int in_socket_list = 0;
- /* get statePtr lock */
+
+ /*
+ * Get statePtr lock.
+ */
+
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
@@ -1722,8 +1831,8 @@ TcpConnect(
* It is set after this call by TcpThreadActionProc and is set
* on a second round.
*
- * If not, we buffer my statePtr in the tsd memory so it is not
- * lost by the event procedure
+ * If not, we buffer my statePtr in the tsd memory so it is
+ * not lost by the event procedure
*/
for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL;
@@ -1736,21 +1845,27 @@ TcpConnect(
if (!in_socket_list) {
tsdPtr->pendingTcpState = statePtr;
}
+
/*
* Set connect mask to connect events
- * This is activated by a SOCKET_SELECT message to the notifier
- * thread.
+ *
+ * This is activated by a SOCKET_SELECT message to the
+ * notifier thread.
*/
- statePtr->selectEvents |= FD_CONNECT;
+
+ SET_BITS(statePtr->selectEvents, FD_CONNECT);
/*
- * Free list lock
+ * Free list lock.
*/
+
SetEvent(tsdPtr->socketListLock);
- /* activate accept notification */
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) statePtr);
+ /*
+ * Activate accept notification.
+ */
+
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
}
/*
@@ -1766,12 +1881,11 @@ TcpConnect(
if (async_connect && error == WSAEWOULDBLOCK) {
/*
* Asynchroneous connect
- */
-
- /*
+ *
* Remember that we jump back behind this next round
*/
- statePtr->flags |= TCP_ASYNC_PENDING;
+
+ SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
return TCL_OK;
reenter:
@@ -1781,14 +1895,31 @@ TcpConnect(
*
* Clear the reenter flag
*/
- statePtr->flags &= ~(TCP_ASYNC_PENDING);
- /* get statePtr lock */
+
+ CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
+
+ /*
+ * Get statePtr lock.
+ */
+
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- /* Get signaled connect error */
+
+ /*
+ * Get signaled connect error.
+ */
+
TclWinConvertError((DWORD) statePtr->notifierConnectError);
- /* Clear eventual connect flag */
- statePtr->selectEvents &= ~(FD_CONNECT);
- /* Free list lock */
+
+ /*
+ * Clear eventual connect flag.
+ */
+
+ CLEAR_BITS(statePtr->selectEvents, FD_CONNECT);
+
+ /*
+ * Free list lock.
+ */
+
SetEvent(tsdPtr->socketListLock);
}
@@ -1796,6 +1927,7 @@ TcpConnect(
* Clear the tsd socket list pointer if we did not wait for
* the FD_CONNECT asynchroneously
*/
+
tsdPtr->pendingTcpState = NULL;
if (Tcl_GetErrno() == 0) {
@@ -1804,7 +1936,7 @@ TcpConnect(
}
}
-out:
+ out:
/*
* Socket connected or connection failed
*/
@@ -1815,13 +1947,13 @@ out:
CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
- if ( Tcl_GetErrno() == 0 ) {
+ if (Tcl_GetErrno() == 0) {
/*
* Succesfully connected
- */
- /*
+ *
* Set up the select mask for read/write events.
*/
+
statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
/*
@@ -1829,35 +1961,56 @@ out:
* automatically places the socket into non-blocking mode.
*/
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) statePtr);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
} else {
/*
* Connect failed
- */
-
- /*
+ *
* For async connect schedule a writable event to report the fail.
*/
+
if (async_callback) {
/*
* Set up the select mask for read/write events.
*/
+
statePtr->selectEvents = FD_WRITE|FD_READ;
- /* get statePtr lock */
+
+ /*
+ * Get statePtr lock.
+ */
+
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- /* Signal ready readable and writable events */
- statePtr->readyEvents |= FD_WRITE | FD_READ;
- /* Flag error to event routine */
- statePtr->flags |= TCP_ASYNC_FAILED;
- /* Save connect error to be reported by 'fconfigure -error' */
+
+ /*
+ * Signal ready readable and writable events.
+ */
+
+ SET_BITS(statePtr->readyEvents, FD_WRITE | FD_READ);
+
+ /*
+ * Flag error to event routine.
+ */
+
+ SET_BITS(statePtr->flags, TCP_ASYNC_FAILED);
+
+ /*
+ * Save connect error to be reported by 'fconfigure -error'.
+ */
+
statePtr->connectError = Tcl_GetErrno();
- /* Free list lock */
+
+ /*
+ * Free list lock.
+ */
+
SetEvent(tsdPtr->socketListLock);
}
+
/*
* Error message on synchroneous connect
*/
+
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", Tcl_PosixError(interp)));
@@ -1935,7 +2088,7 @@ Tcl_OpenTcpClient(
statePtr->addrlist = addrlist;
statePtr->myaddrlist = myaddrlist;
if (async) {
- statePtr->flags |= TCP_ASYNC_CONNECT;
+ SET_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
}
/*
@@ -1990,7 +2143,7 @@ Tcl_MakeTcpClientChannel(
return NULL;
}
- tsdPtr = TclThreadDataKeyGet(&dataKey);
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Set kernel space buffering and non-blocking.
@@ -2005,7 +2158,7 @@ Tcl_MakeTcpClientChannel(
*/
statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
sprintf(channelName, SOCK_TEMPLATE, statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
@@ -2017,7 +2170,7 @@ Tcl_MakeTcpClientChannel(
/*
*----------------------------------------------------------------------
*
- * Tcl_OpenTcpServer --
+ * Tcl_OpenTcpServerEx --
*
* Opens a TCP server socket and creates a channel around it.
*
@@ -2032,10 +2185,11 @@ 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. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
@@ -2049,6 +2203,7 @@ 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;
@@ -2068,7 +2223,13 @@ Tcl_OpenTcpServer(
* Construct the addresses for each end of the socket.
*/
- if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
+ if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) {
+ errorMsg = "invalid port number";
+ goto error;
+ }
+
+ if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1,
+ &errorMsg)) {
goto error;
}
@@ -2107,17 +2268,26 @@ 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
* place to look for bugs.
*/
- if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
- == SOCKET_ERROR) {
+ if (bind(sock, addrPtr->ai_addr,
+ addrPtr->ai_addrlen) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
closesocket(sock);
continue;
@@ -2152,19 +2322,20 @@ Tcl_OpenTcpServer(
/*
* Add this socket to the global list of sockets.
*/
+
statePtr = NewSocketInfo(sock);
} else {
- AddSocketInfoFd( statePtr, sock );
+ AddSocketInfoFd(statePtr, sock);
}
}
-error:
+ error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
@@ -2183,8 +2354,7 @@ error:
*/
ioctlsocket(sock, (long) FIONBIO, &flag);
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) statePtr);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "")
== TCL_ERROR) {
Tcl_Close(NULL, statePtr->channel);
@@ -2232,7 +2402,7 @@ TcpAccept(
int len = sizeof(addr);
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Win-NT has a misfeature that sockets are inherited in child processes
@@ -2252,8 +2422,7 @@ TcpAccept(
*/
newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) newInfoPtr);
+ SendSelectMessage(tsdPtr, SELECT, newInfoPtr);
sprintf(channelName, SOCK_TEMPLATE, newInfoPtr);
newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
@@ -2304,7 +2473,7 @@ static void
InitSockets(void)
{
DWORD id;
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (!initialized) {
initialized = 1;
@@ -2323,7 +2492,7 @@ InitSockets(void)
windowClass.hInstance = TclWinGetTclInstance();
windowClass.hbrBackground = NULL;
windowClass.lpszMenuName = NULL;
- windowClass.lpszClassName = classname;
+ windowClass.lpszClassName = className;
windowClass.lpfnWndProc = SocketProc;
windowClass.hIcon = NULL;
windowClass.hCursor = NULL;
@@ -2441,7 +2610,7 @@ SocketsEnabled(void)
static void
SocketExitHandler(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&socketMutex);
@@ -2451,7 +2620,7 @@ SocketExitHandler(
*/
TclpFinalizeSockets();
- UnregisterClassW(classname, TclWinGetTclInstance());
+ UnregisterClassW(className, TclWinGetTclInstance());
initialized = 0;
Tcl_MutexUnlock(&socketMutex);
}
@@ -2475,14 +2644,14 @@ SocketExitHandler(
void
SocketSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
return;
}
@@ -2492,9 +2661,8 @@ SocketSetupProc(
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
- if (statePtr->readyEvents &
- (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
- ) {
+ if (GOT_BITS(statePtr->readyEvents,
+ statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) {
Tcl_SetMaxBlockTime(&blockTime);
break;
}
@@ -2521,14 +2689,14 @@ SocketSetupProc(
static void
SocketCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
SocketEvent *evPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
return;
}
@@ -2541,12 +2709,11 @@ SocketCheckProc(
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
- if ((statePtr->readyEvents &
- (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT))
- && !(statePtr->flags & SOCKET_PENDING)
- ) {
- statePtr->flags |= SOCKET_PENDING;
- evPtr = ckalloc(sizeof(SocketEvent));
+ if (GOT_BITS(statePtr->readyEvents,
+ statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
+ && !GOT_BITS(statePtr->flags, SOCKET_PENDING)) {
+ SET_BITS(statePtr->flags, SOCKET_PENDING);
+ evPtr = (SocketEvent *)ckalloc(sizeof(SocketEvent));
evPtr->header.proc = SocketEventProc;
evPtr->socket = statePtr->sockets->fd;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -2591,7 +2758,7 @@ SocketEventProc(
address addr;
int len;
- if (!(flags & TCL_FILE_EVENTS)) {
+ if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
return 0;
}
@@ -2620,29 +2787,26 @@ SocketEventProc(
* Clear flag that (this) event is pending
*/
- statePtr->flags &= ~SOCKET_PENDING;
+ CLEAR_BITS(statePtr->flags, SOCKET_PENDING);
/*
* Continue async connect if pending and ready
*/
- if ( statePtr->readyEvents & FD_CONNECT ) {
- if ( statePtr->flags & TCP_ASYNC_PENDING ) {
-
+ if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* Do one step and save eventual connect error
*/
SetEvent(tsdPtr->socketListLock);
WaitForConnect(statePtr,NULL);
-
} else {
-
/*
* No async connect reenter pending. Just clear event.
*/
- statePtr->readyEvents &= ~(FD_CONNECT);
+ CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);
SetEvent(tsdPtr->socketListLock);
}
return 1;
@@ -2651,20 +2815,23 @@ SocketEventProc(
/*
* Handle connection requests directly.
*/
- if (statePtr->readyEvents & FD_ACCEPT) {
- for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
+ if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) {
+ for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
/*
- * Accept the incoming connection request.
- */
- len = sizeof(address);
+ * Accept the incoming connection request.
+ */
+ len = sizeof(address);
newSocket = accept(fds->fd, &(addr.sa), &len);
- /* On Tcl server sockets with multiple OS fds we loop over the fds trying
- * an accept() on each, so we expect INVALID_SOCKET. There are also other
- * network stack conditions that can result in FD_ACCEPT but a subsequent
- * failure on accept() by the time we get around to it.
+ /*
+ * On Tcl server sockets with multiple OS fds we loop over the fds
+ * trying an accept() on each, so we expect INVALID_SOCKET. There
+ * are also other network stack conditions that can result in
+ * FD_ACCEPT but a subsequent failure on accept() by the time we
+ * get around to it.
+ *
* Access to sockets (acceptEventCount, readyEvents) in socketList
* is still protected by the lock (prevents reintroduction of
* SF Tcl Bug 3056775.
@@ -2676,35 +2843,40 @@ SocketEventProc(
}
/*
- * It is possible that more than one FD_ACCEPT has been sent, so an extra
- * count must be kept. Decrement the count, and reset the readyEvent bit
- * if the count is no longer > 0.
+ * It is possible that more than one FD_ACCEPT has been sent, so
+ * an extra count must be kept. Decrement the count, and reset the
+ * readyEvent bit if the count is no longer > 0.
*/
+
statePtr->acceptEventCount--;
if (statePtr->acceptEventCount <= 0) {
- statePtr->readyEvents &= ~(FD_ACCEPT);
+ CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);
}
SetEvent(tsdPtr->socketListLock);
- /* Caution: TcpAccept() has the side-effect of evaluating the server
- * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can
- * close the server socket and invalidate statePtr and fds.
- * If TcpAccept() accepts a socket we must return immediately and let
- * SocketCheckProc queue additional FD_ACCEPT events.
+ /*
+ * Caution: TcpAccept() has the side-effect of evaluating the
+ * server accept script (via AcceptCallbackProc() in tclIOCmd.c),
+ * which can close the server socket and invalidate statePtr and
+ * fds. If TcpAccept() accepts a socket we must return immediately
+ * and let SocketCheckProc queue additional FD_ACCEPT events.
*/
+
TcpAccept(fds, newSocket, addr);
return 1;
}
- /* Loop terminated with no sockets accepted; clear the ready mask so
+ /*
+ * Loop terminated with no sockets accepted; clear the ready mask so
* we can detect the next connection request. Note that connection
* requests are level triggered, so if there is a request already
* pending, a new event will be generated.
*/
+
statePtr->acceptEventCount = 0;
- statePtr->readyEvents &= ~(FD_ACCEPT);
+ CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);
SetEvent(tsdPtr->socketListLock);
return 1;
@@ -2719,7 +2891,7 @@ SocketEventProc(
events = statePtr->readyEvents & statePtr->watchEvents;
- if (events & FD_CLOSE) {
+ if (GOT_BITS(events, FD_CLOSE)) {
/*
* If the socket was closed and the channel is still interested in
* read events, then we need to ensure that we keep polling for this
@@ -2733,17 +2905,14 @@ SocketEventProc(
Tcl_Time blockTime = { 0, 0 };
Tcl_SetMaxBlockTime(&blockTime);
- mask |= TCL_READABLE|TCL_WRITABLE;
- } else if (events & FD_READ) {
-
+ SET_BITS(mask, TCL_READABLE | TCL_WRITABLE);
+ } else if (GOT_BITS(events, FD_READ)) {
/*
* Throw the readable event if an async connect failed.
*/
- if ( statePtr->flags & TCP_ASYNC_FAILED ) {
-
- mask |= TCL_READABLE;
-
+ if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
+ SET_BITS(mask, TCL_READABLE);
} else {
fd_set readFds;
struct timeval timeout;
@@ -2756,8 +2925,7 @@ SocketEventProc(
* async select handler and keep waiting.
*/
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) statePtr);
+ SendSelectMessage(tsdPtr, UNSELECT, statePtr);
FD_ZERO(&readFds);
FD_SET(statePtr->sockets->fd, &readFds);
@@ -2765,11 +2933,10 @@ SocketEventProc(
timeout.tv_sec = 0;
if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
- mask |= TCL_READABLE;
+ SET_BITS(mask, TCL_READABLE);
} else {
- statePtr->readyEvents &= ~(FD_READ);
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) statePtr);
+ CLEAR_BITS(statePtr->readyEvents, FD_READ);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
}
}
}
@@ -2778,8 +2945,8 @@ SocketEventProc(
* writable event
*/
- if (events & FD_WRITE) {
- mask |= TCL_WRITABLE;
+ if (GOT_BITS(events, FD_WRITE)) {
+ SET_BITS(mask, TCL_WRITABLE);
}
/*
@@ -2816,21 +2983,30 @@ AddSocketInfoFd(
{
TcpFdList *fds = statePtr->sockets;
- if ( fds == NULL ) {
- /* Add the first FD */
- statePtr->sockets = ckalloc(sizeof(TcpFdList));
+ if (fds == NULL) {
+ /*
+ * Add the first FD.
+ */
+
+ statePtr->sockets = (TcpFdList *)ckalloc(sizeof(TcpFdList));
fds = statePtr->sockets;
} else {
- /* Find end of list and append FD */
- while ( fds->next != NULL ) {
+ /*
+ * Find end of list and append FD.
+ */
+
+ while (fds->next != NULL) {
fds = fds->next;
}
- fds->next = ckalloc(sizeof(TcpFdList));
+ fds->next = (TcpFdList *)ckalloc(sizeof(TcpFdList));
fds = fds->next;
}
- /* Populate new FD */
+ /*
+ * Populate new FD.
+ */
+
fds->fd = socket;
fds->statePtr = statePtr;
fds->next = NULL;
@@ -2856,7 +3032,7 @@ AddSocketInfoFd(
static TcpState *
NewSocketInfo(SOCKET socket)
{
- TcpState *statePtr = ckalloc(sizeof(TcpState));
+ TcpState *statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
@@ -2899,7 +3075,8 @@ WaitForSocketEvent(
{
int result = 1;
int oldMode;
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+
/*
* Be sure to disable event servicing so we are truly modal.
*/
@@ -2910,29 +3087,42 @@ WaitForSocketEvent(
* Reset WSAAsyncSelect so we have a fresh set of events pending.
*/
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
- (LPARAM) statePtr);
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
- (LPARAM) statePtr);
+ SendSelectMessage(tsdPtr, UNSELECT, statePtr);
+ SendSelectMessage(tsdPtr, SELECT, statePtr);
while (1) {
int event_found;
- /* get statePtr lock */
+ /*
+ * Get statePtr lock.
+ */
+
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- /* Check if event occured */
- event_found = (statePtr->readyEvents & events);
+ /*
+ * Check if event occured.
+ */
+
+ event_found = GOT_BITS(statePtr->readyEvents, events);
+
+ /*
+ * Free list lock.
+ */
- /* Free list lock */
SetEvent(tsdPtr->socketListLock);
- /* exit loop if event occured */
+ /*
+ * Exit loop if event occured.
+ */
+
if (event_found) {
break;
}
- /* Exit loop if event did not occur but this is a non-blocking channel */
+ /*
+ * Exit loop if event did not occur but this is a non-blocking channel
+ */
+
if (statePtr->flags & TCP_NONBLOCKING) {
*errorCodePtr = EWOULDBLOCK;
result = 0;
@@ -2971,13 +3161,13 @@ SocketThread(
LPVOID arg)
{
MSG msg;
- ThreadSpecificData *tsdPtr = arg;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)arg;
/*
* Create a dummy window receiving socket events.
*/
- tsdPtr->hwnd = CreateWindowW(classname, classname, WS_TILED, 0, 0, 0, 0,
+ tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0,
NULL, NULL, windowClass.hInstance, arg);
/*
@@ -3089,55 +3279,59 @@ SocketProc(
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
- if ( FindFDInList(statePtr,socket) ) {
+ if (FindFDInList(statePtr, socket)) {
info_found = 1;
break;
}
}
+
/*
- * Check if there is a pending info structure not jet in the
- * list
+ * Check if there is a pending info structure not jet in the list.
*/
- if ( !info_found
+
+ if (!info_found
&& tsdPtr->pendingTcpState != NULL
- && FindFDInList(tsdPtr->pendingTcpState,socket) ) {
+ && FindFDInList(tsdPtr->pendingTcpState, socket)) {
statePtr = tsdPtr->pendingTcpState;
info_found = 1;
}
if (info_found) {
-
/*
* Update the socket state.
*
* A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
- * happens, then clear the FD_ACCEPT count. Otherwise,
- * increment the count if the current event is an FD_ACCEPT.
+ * happens, then clear the FD_ACCEPT count. Otherwise, increment
+ * the count if the current event is an FD_ACCEPT.
*/
- if (event & FD_CLOSE) {
+ if (GOT_BITS(event, FD_CLOSE)) {
statePtr->acceptEventCount = 0;
- statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
- } else if (event & FD_ACCEPT) {
+ CLEAR_BITS(statePtr->readyEvents, FD_WRITE | FD_ACCEPT);
+ } else if (GOT_BITS(event, FD_ACCEPT)) {
statePtr->acceptEventCount++;
}
- if (event & FD_CONNECT) {
+ if (GOT_BITS(event, FD_CONNECT)) {
/*
* Remember any error that occurred so we can report
* connection failures.
*/
+
if (error != ERROR_SUCCESS) {
statePtr->notifierConnectError = error;
}
}
+
/*
* Inform main thread about signaled events
*/
- statePtr->readyEvents |= event;
+
+ SET_BITS(statePtr->readyEvents, event);
/*
* Wake up the Main Thread.
*/
+
SetEvent(tsdPtr->readyEvent);
Tcl_ThreadAlert(tsdPtr->threadId);
}
@@ -3218,6 +3412,7 @@ FindFDInList(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef TclWinGetSockOpt
int
TclWinGetSockOpt(
@@ -3257,6 +3452,7 @@ TclWinGetServByName(
{
return getservbyname(name, proto);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3280,7 +3476,7 @@ TcpThreadActionProc(
int action)
{
ThreadSpecificData *tsdPtr;
- TcpState *statePtr = instanceData;
+ TcpState *statePtr = (TcpState *)instanceData;
int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
@@ -3346,8 +3542,7 @@ TcpThreadActionProc(
* thread.
*/
- SendMessageW(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) notifyCmd, (LPARAM) statePtr);
+ SendSelectMessage(tsdPtr, notifyCmd, statePtr);
}
/*
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index 8525718..91a3010 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -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
@@ -32,21 +37,14 @@
* Forward declarations of functions defined later in this file:
*/
-static int TesteventloopCmd(ClientData dummy, Tcl_Interp* interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestvolumetypeCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int TestwinclockCmd(ClientData dummy, Tcl_Interp* interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestSizeCmd(ClientData dummy, Tcl_Interp* interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc TesteventloopCmd;
+static Tcl_ObjCmdProc TestvolumetypeCmd;
+static Tcl_ObjCmdProc TestwinclockCmd;
+static Tcl_ObjCmdProc TestwinsleepCmd;
+static Tcl_ObjCmdProc TestSizeCmd;
static Tcl_ObjCmdProc TestExceptionCmd;
static int TestplatformChmod(const char *nativePath, int pmode);
-static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc TestchmodCmd;
/*
*----------------------------------------------------------------------
@@ -104,7 +102,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. */
@@ -180,7 +178,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. */
@@ -246,7 +244,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 */
@@ -279,11 +277,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));
@@ -295,7 +293,7 @@ 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 */
@@ -315,11 +313,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;
}
@@ -363,7 +362,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 */
@@ -416,7 +415,6 @@ TestExceptionCmd(
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
- /* NOTREACHED */
return TCL_OK;
}
@@ -493,7 +491,7 @@ TestplatformChmod(
goto done;
}
- secDesc = ckalloc(secDescLen);
+ secDesc = (BYTE *)ckalloc(secDescLen);
if (!GetFileSecurityA(nativePath, infoBits,
(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
|| (secDescLen < secDescLen2)) {
@@ -505,7 +503,7 @@ TestplatformChmod(
* Get the World SID.
*/
- userSid = ckalloc(GetSidLengthRequired((UCHAR) 1));
+ userSid = (SID *)ckalloc(GetSidLengthRequired((UCHAR) 1));
InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
*(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
@@ -531,7 +529,7 @@ TestplatformChmod(
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
- newAcl = ckalloc(newAclSize);
+ newAcl = (PACL) ckalloc(newAclSize);
/*
* Initialize the new ACL.
@@ -652,7 +650,7 @@ 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 */
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index 5316075..89f2b12 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -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 masterLock;
-static int init = 0;
-#define MASTER_LOCK TclpMasterLock()
-#define MASTER_UNLOCK TclpMasterUnlock()
-
+static int initialized = 0;
/*
* This is the master lock used to serialize initialization and finalization
@@ -46,7 +41,7 @@ static CRITICAL_SECTION initLock;
* 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);
}
@@ -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(&masterLock);
@@ -419,7 +413,7 @@ TclpInitUnlock(void)
void
TclpMasterLock(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 @@ TclpMasterLock(void)
* that create interpreters in parallel.
*/
- init = 1;
+ initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&masterLock);
@@ -480,7 +474,7 @@ TclpMasterUnlock(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)
{
- MASTER_LOCK;
+ TclpMasterLock();
DeleteCriticalSection(&joinLock);
/*
@@ -520,9 +514,9 @@ TclFinalizeLock(void)
*/
DeleteCriticalSection(&masterLock);
- 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,19 +561,19 @@ Tcl_MutexLock(
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
- MASTER_LOCK;
+ TclpMasterLock();
/*
* Double inside master lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
- csPtr = ckalloc(sizeof(CRITICAL_SECTION));
+ csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
}
- MASTER_UNLOCK;
+ TclpMasterUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
EnterCriticalSection(csPtr);
@@ -681,7 +675,7 @@ Tcl_ConditionWait(
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
- MASTER_LOCK;
+ TclpMasterLock();
/*
* Create the per-thread event and queue pointers.
@@ -695,7 +689,7 @@ Tcl_ConditionWait(
tsdPtr->flags = WIN_THREAD_RUNNING;
doExit = 1;
}
- MASTER_UNLOCK;
+ TclpMasterUnlock();
if (doExit) {
/*
@@ -710,21 +704,21 @@ Tcl_ConditionWait(
}
if (*condPtr == NULL) {
- MASTER_LOCK;
+ TclpMasterLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
- winCondPtr = ckalloc(sizeof(WinCondition));
+ winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition));
InitializeCriticalSection(&winCondPtr->condLock);
winCondPtr->firstPtr = NULL;
winCondPtr->lastPtr = NULL;
*condPtr = (Tcl_Condition) winCondPtr;
TclRememberCondition(condPtr);
}
- MASTER_UNLOCK;
+ TclpMasterUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
winCondPtr = *((WinCondition **)condPtr);
@@ -944,9 +938,9 @@ TclpFinalizeCondition(
Tcl_Mutex *
TclpNewAllocMutex(void)
{
- struct allocMutex *lockPtr;
+ allocMutex *lockPtr;
- lockPtr = 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 */
@@ -1045,7 +1037,7 @@ TclpThreadCreateKey(void)
{
DWORD *key;
- key = TclpSysAlloc(sizeof *key, 0);
+ key = (DWORD *)TclpSysAlloc(sizeof *key, 0);
if (key == NULL) {
Tcl_Panic("unable to allocate thread key!");
}
@@ -1063,7 +1055,7 @@ void
TclpThreadDeleteKey(
void *keyPtr)
{
- DWORD *key = keyPtr;
+ DWORD *key = (DWORD *)keyPtr;
if (!TlsFree(*key)) {
Tcl_Panic("unable to delete key");
@@ -1077,7 +1069,7 @@ TclpThreadSetMasterTSD(
void *tsdKeyPtr,
void *ptr)
{
- DWORD *key = tsdKeyPtr;
+ DWORD *key = (DWORD *)tsdKeyPtr;
if (!TlsSetValue(*key, ptr)) {
Tcl_Panic("unable to set master TSD value");
@@ -1088,7 +1080,7 @@ void *
TclpThreadGetMasterTSD(
void *tsdKeyPtr)
{
- DWORD *key = tsdKeyPtr;
+ DWORD *key = (DWORD *)tsdKeyPtr;
return TlsGetValue(*key);
}
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index 976dd61..ef2b9d2 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -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,17 +36,18 @@ 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. */
@@ -96,7 +98,7 @@ static TimeInfo timeInfo = {
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
-#ifdef HAVE_CAST_TO_UNION
+#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
(LARGE_INTEGER) (Tcl_WideInt) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
@@ -129,7 +131,9 @@ 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);
@@ -409,8 +413,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.
@@ -515,7 +519,7 @@ NativeGetMicroseconds(void)
*/
SYSTEM_INFO systemInfo;
- unsigned int regs[4];
+ int regs[4];
GetSystemInfo(&systemInfo);
if (TclWinCPUID(0, regs) == TCL_OK
@@ -527,7 +531,7 @@ NativeGetMicroseconds(void)
|| ((regs[0] & 0x00F00000) /* Extended family */
&& (regs[3] & 0x10000000))) /* Hyperthread */
&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
- == systemInfo.dwNumberOfProcessors)) {
+ == (int)systemInfo.dwNumberOfProcessors)) {
timeInfo.perfCounterAvailable = TRUE;
} else {
timeInfo.perfCounterAvailable = FALSE;
@@ -645,7 +649,7 @@ NativeGetMicroseconds(void)
static void
NativeGetTime(
Tcl_Time *timePtr,
- ClientData clientData)
+ TCL_UNUSED(ClientData))
{
Tcl_WideInt usecSincePosixEpoch;
@@ -690,7 +694,7 @@ void TclWinResetTimerResolution(void);
static void
StopCalibration(
- ClientData unused) /* Client data is unused */
+ TCL_UNUSED(ClientData))
{
SetEvent(timeInfo.exitEvent);
@@ -722,6 +726,7 @@ StopCalibration(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGetDate(
const time_t *t,
@@ -938,6 +943,7 @@ ComputeGMT(
return tmPtr;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -967,7 +973,7 @@ ComputeGMT(
static DWORD WINAPI
CalibrationThread(
- LPVOID arg)
+ TCL_UNUSED(LPVOID))
{
FILETIME curFileTime;
DWORD waitResult;
@@ -1011,7 +1017,6 @@ CalibrationThread(
UpdateTimeEachSecond();
}
- /* lint */
return (DWORD) 0;
}
@@ -1344,6 +1349,7 @@ AccumulateSample(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGmtime(
const time_t *timePtr) /* Pointer to the number of seconds since the
@@ -1396,6 +1402,7 @@ TclpLocaltime(
return _localtime32((const __time32_t *)timePtr);
#endif
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh
index 2279542..4c2068c 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.2.0
diff --git a/win/tclsh.rc b/win/tclsh.rc
index 161da50..bd1a4da 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 */