Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge trunk |
|---|---|
| Timelines: | family | ancestors | descendants | both | dgp-pkg-migration |
| Files: | files | file ages | folders |
| SHA1: |
a33431908c10edc62d172d58cad245de |
| User & Date: | dgp 2013-01-19 13:36:57.316 |
Context
|
2014-07-15
| ||
| 13:18 | merge trunk Leaf check-in: 6559584842 user: dgp tags: dgp-pkg-migration | |
|
2013-01-19
| ||
| 13:36 | merge trunk check-in: a33431908c user: dgp tags: dgp-pkg-migration | |
|
2013-01-17
| ||
| 15:13 | COMPILE_DEBUG big: fix bug in stack verification for {*} check-in: 187e70fc60 user: mig tags: trunk | |
|
2012-06-21
| ||
| 21:36 | merge trunk check-in: 7c4c6a5dfc user: dgp tags: dgp-pkg-migration | |
Changes
Changes to ChangeLog.
1 2 | 2012-06-21 Jan Nijtmans <nijtmans@users.sf.net> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
2013-01-17 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCompCmds.c (PushVarName): [Bug 3600328]: Added mechanism
for suppressing compilation of variables when we couldn't cope with
the results. Useful for some [array] subcommands.
* generic/tclEnsemble.c (CompileToCompiledCommand): Must restore the
compilation environment when a command compiler fails.
2013-01-16 Donal K. Fellows <dkf@users.sf.net>
* generic/tclZlib.c (TclZlibInit): [Bug 3601086]: Register the config
info in the iso8859-1 encoding as that is guaranteed to be present.
2013-01-16 Jan Nijtmans <nijtmans@users.sf.net>
* Makefile.in: Allow win32 build with -DTCL_NO_DEPRECATED, just as
* generic/tcl.h: in the UNIX build. Define Tcl_EvalObj and
* generic/tclDecls.h: Tcl_GlobalEvalObj as macros, even when
* generic/tclBasic.c: TCL_NO_DEPRECATED is defined, so Tk can benefit
from it too.
2013-01-14 Jan Nijtmans <nijtmans@users.sf.net>
* win/tcl.m4: More flexible search for win32 tclConfig.sh, backported
from TEA (not actually used in Tcl, only for Tk)
2013-01-14 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclInt.decls: Put back Tcl_[GS]etStartupScript in internal
stub table, so extensions using this, compiled against 8.5 headers
still run in Tcl 8.6.
2013-01-13 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false
positives" in the case of multibyte encodings/transforms.
2013-01-13 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make sure
that TIP #139 functions all are taken from the public stub table, even
if the inclusion is through tclInt.h.
2013-01-12 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclInt.decls: Put back TclBackgroundException in internal
stub table, so extensions using this, compiled against 8.5 headers
still run in Tcl 8.6.
2013-01-09 Jan Nijtmans <nijtmans@users.sf.net>
* library/http/http.tcl: [Bug 3599395]: http assumes status line is a
proper Tcl list.
2013-01-08 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinFile.c: [Bug 3092089]: [file normalize] can remove path
components. [Bug 3587096] win vista/7: "can't find init.tcl" when
called via junction without folder list access.
2013-01-07 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclOOStubLib.c: Restrict the stub library to only use
* generic/tclTomMathStubLib.c: Tcl_PkgRequireEx, Tcl_ResetResult and
Tcl_AppendResult, not any other function. This puts least restrictions
on eventual Tcl 9 stubs re-organization, and it works on the widest
range of Tcl versions.
2013-01-06 Jan Nijtmans <nijtmans@users.sf.net>
* library/http/http.tcl: Don't depend on Spencer-specific regexp
* tests/env.test: syntax (/u and /U) any more in unrelated places.
* tests/exec.test:
Bump http package to 2.8.6.
2013-01-04 Donal K. Fellows <dkf@users.sf.net>
* generic/tclEnsemble.c (CompileBasicNArgCommand): Added very simple
compiler (which just compiles to a normal invoke of the implementation
command) for many ensemble subcommands where we can prove that there
is no way for scripts to detect the difference even through error
handling or [info level]/[info frame]. This improves the code produced
from some ensembles (e.g., [info], [string]) to the point where the
ensemble is now not normally seen at the bytecode level at all.
2013-01-04 Miguel Sofer <msofer@users.sf.net>
* generic/tclInt.h: Insure that PURIFY builds cannot exploit the
* generic/tclExecute.c: Tcl stack to hide mem defects.
2013-01-03 Donal K. Fellows <dkf@users.sf.net>
* doc/fconfigure.n, doc/CrtChannel.3: Updated to reflect the fact that
the minimum buffer size is one byte, not ten. Identified by Schelte
Bron on the Tcler's Chat.
* generic/tclExecute.c (TEBCresume:INST_INVOKE_REPLACE):
* generic/tclEnsemble.c (TclCompileEnsemble): Added new mechanism to
allow for more efficient dispatch of non-bytecode-compiled subcommands
of bytecode-compiled ensembles. This can provide substantial speed
benefits in some cases.
2013-01-02 Miguel Sofer <msofer@users.sf.net>
* generic/tclEnsemble.c: Remove stray calls to Tcl_Alloc and friends:
* generic/tclExecute.c: the core should only use ckalloc to allow
* generic/tclIORTrans.c: MEM_DEBUG to work properly.
* generic/tclTomMathInterface.c:
2012-12-31 Donal K. Fellows <dkf@users.sf.net>
* doc/string.n: Noted the obsolescence of the 'bytelength',
'wordstart' and 'wordend' subcommands, and moved them to later in the
file.
2012-12-27 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclListObj.c: [Bug 3598580]: Tcl_ListObjReplace may release
deleted elements too early.
2012-12-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclUtil.c: Stop leaking allocated space when objifying a
zero-length DString. [Bug 3598150] spotted by afredd.
2012-12-21 Jan Nijtmans <nijtmans@users.sf.net>
* unix/dltest/pkgb.c: Inline compat Tcl_GetDefaultEncodingDir.
* generic/tclStubLib.c: Eliminate unnecessary static HasStubSupport()
and isDigit() functions, just do the same inline.
2012-12-18 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCompCmdsSZ.c (TclSubstCompile): Improved the sequence of
instructions issued for [subst] when dealing with simple variable
references.
2012-12-14 Don Porter <dgp@users.sourceforge.net>
*** 8.6.0 TAGGED FOR RELEASE ***
* changes: updates for 8.6.0
2012-12-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclZlib.c: Repair same issue with misusing the
* tests/zlib.test: 'fire and forget' nature of Tcl_ObjSetVar2
in the new TIP 400 implementation.
2012-12-13 Miguel Sofer <msofer@users.sf.net>
* generic/tclCmdAH.c: (CatchObjCmdCallback): do not decrRefCount
* tests/cmdAH.test: the newValuePtr sent to Tcl_ObjSetVar2:
TOSV2 is 'fire and forget', it decrs on its own.
Fix for [Bug 3595576], found by andrewsh.
2012-12-13 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tcl.h: Fix Tcl_DecrRefCount macro such that it doesn't
access its objPtr parameter twice any more.
2012-12-11 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h: Bump version number to 8.6.0.
* library/init.tcl:
* unix/configure.in:
* win/configure.in:
* unix/tcl.spec:
* README:
* unix/configure: autoconf-2.59
* win/configure:
2012-12-10 Donal K. Fellows <dkf@users.sf.net>
* tools/tcltk-man2html.tcl (plus-pkgs): Increased robustness of
version number detection code to deal with packages whose names are
prefixes of other packages.
* unix/Makefile.in (dist): Added pkgs/package.list.txt to distribution
builds to ensure that 'make html' will work better.
2012-12-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* tests/chan.test: Clean up unwanted eofchar side-effect of chan-4.6
leading to a spurious "'" at end of chan.test under certain conditions
(see [Bug 3389289] and [Bug 3389251]).
* doc/expr.n: [Bug 3594188]: Clarifications about commas.
2012-12-08 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT
when there are unflushed nonblocking channels. Thanks Miguel for
spotting.
2012-12-07 Jan Nijtmans <nijtmans@users.sf.net>
* unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test
library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should
either result in an error-message, either succeed, but never crash.
2012-11-28 Donal K. Fellows <dkf@users.sf.net>
* generic/tclZlib.c (ZlibStreamSubcmd): [Bug 3590483]: Use a mechanism
for complex option resolution that has fewer problems with more
finicky compilers.
2012-11-26 Reinhard Max <max@suse.de>
* unix/tclUnixSock.c: Factor out creation of the -sockname and
-peername lists from TcpGetOptionProc() to TcpHostPortList(). Make it
robust against implementations of getnameinfo() that error out if
reverse mapping fails instead of falling back to the numeric
representation.
2012-11-20 Donal K. Fellows <dkf@users.sf.net>
* generic/tclBinary.c (BinaryDecode64): [Bug 3033307]: Corrected
handling of trailing whitespace when decoding base64. Thanks to Anton
Kovalenko for reporting, and Andy Goth for the fix and tests.
2012-11-19 Donal K. Fellows <dkf@users.sf.net>
* generic/tclExecute.c (INST_STR_RANGE_IMM): [Bug 3588366]: Corrected
implementation of bounds restriction for end-indexed compiled [string
range]. Thanks to Emiliano Gavilan for diagnosis and fix.
2012-11-15 Jan Nijtmans <nijtmans@users.sf.net>
IMPLEMENTATION OF TIP#416
New Options for 'load': -global and -lazy
* generic/tcl.h:
* generic/tclLoad.c
* unix/tclLoadDl.c
* unix/tclLoadDyld.c
* tests/load.test
* doc/Load.3
* doc/load.n
2012-11-14 Donal K. Fellows <dkf@users.sf.net>
* unix/tclUnixFCmd.c (TclUnixOpenTemporaryFile): [Bug 2933003]: Factor
out all the code to do temporary file creation so that it is possible
to make it correct in one place. Allow overriding of the back-stop
default temporary file location at compile time by setting the
TCL_TEMPORARY_FILE_DIRECTORY #def to a string containing the directory
name (defaults to "/tmp" as that is the most common default).
2012-11-13 Joe Mistachkin <joe@mistachkin.com>
* win/tclWinInit.c: also search for the library directory (init.tcl,
encodings, etc) relative to the build directory associated with the
source checkout.
2012-11-10 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c: re-enable bcc-tailcall, after fixing an
* generic/tclExecute.c: infinite loop in the TCL_COMPILE_DEBUG mode
2012-11-07 Kevin B. Kenny <kennykb@acm.org>
* library/tzdata/Africa/Casablanca:
* library/tzdata/America/Araguaina:
* library/tzdata/America/Bahia:
* library/tzdata/America/Havana:
* library/tzdata/Asia/Amman:
* library/tzdata/Asia/Gaza:
* library/tzdata/Asia/Hebron:
* library/tzdata/Asia/Jerusalem:
* library/tzdata/Pacific/Apia:
* library/tzdata/Pacific/Fakaofo:
* library/tzdata/Pacific/Fiji: Import tzdata2012i.
2012-11-06 Donal K. Fellows <dkf@users.sf.net>
* library/http/http.tcl (http::Finish): [Bug 3581754]: Ensure that
callbacks are done at most once to prevent problems with timeouts on a
keep-alive connection (combined with reentrant http package use)
causing excessive stack growth. Not a fix for the underlying problem,
but ensures that pain will be mostly kept away from users.
Bump http package to 2.8.5.
2012-11-05 Donal K. Fellows <dkf@users.sf.net>
Added bytecode compilation of many Tcl commands. Some of these are
total compilations and some are only partial (i.e., only compile in
some cases). The (sub-)commands affected are:
* array: exists, set, unset
* dict: create, exists, merge
* format: (simple cases only)
* info: commands, coroutine, level, object
* info object: class, isa object, namespace
* namespace: current, code, qualifiers, tail, which
* regsub: (only cases convertable to simple [string map])
* self: (only no-argument and [self object] cases)
* string: first, last, map, range
* tailcall:
* yield:
[This was work originally done on the 'dkf-compile-misc-info' branch.]
2012-11-05 Jan Nijtmans <nijtmans@users.sf.net>
IMPLEMENTATION OF TIP#413
Align the [string trim] and [string is space] commands, such that
[string trim] by default trims all characters for which [string is
space] returns 1, augmented with the NUL character.
* generic/tclUtf.c: Add NEL, BOM and two more characters to [string is
space]
* generic/tclCmdMZ.c: Modify [string trim] for Unicode modifications.
* generic/regc_locale.c: Regexp engine must match [string is space]
* doc/string.n
* tests/string.test
***POTENTIAL INCOMPATIBILITY***
Code that relied on characters not previously trimmed being not
removed will notice a difference; it is believed that this is rare,
but a workaround to get the behavior in Tcl 8.5 is to use " \t\n\r" as
an explicit trim set.
2012-10-31 Jan Nijtmans <nijtmans@users.sf.net>
* win/Makefile.in: Dde version number to 1.4.0, ready for Tcl 8.6.0rc1
* win/makefile.vc
* win/tclWinDde.c
* library/dde/pkgIndex.tcl
* tests/winDde.test
2012-10-24 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCompCmds.c (TclCompileDictUnsetCmd): Added compilation of
the [dict unset] command (for scalar var in LVT only).
2012-10-23 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclInt.h: Add "flags" parameter from Tcl_LoadFile to
* generic/tclIOUtil.c: to various internal functions, so these
* generic/tclLoadNone.c: flags are available through the whole
* unix/tclLoad*.c: filesystem for (future) internal use.
* win/tclWinLoad.c:
2012-10-17 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (TclNRCoroutineObjCmd): insure that numlevels
are properly set, fix bug discovered by dkf and reported at
http://code.activestate.com/lists/tcl-core/12213/
2012-10-16 Donal K. Fellows <dkf@users.sf.net>
IMPLEMENTATION OF TIP#405
New commands for applying a transformation to the elements of a list
to produce another list (the [lmap] command) and to the mappings of a
dictionary to produce another dictionary (the [dict map] command). In
both cases, a [continue] will cause the skipping of an element/pair,
and a [break] will terminate the construction early and successfully.
* generic/tclCmdAH.c (Tcl_LmapObjCmd, TclNRLmapCmd): Implementation of
the new [lmap] command, based on (and sharing much of) [foreach].
* generic/tclDictObj.c (DictMapNRCmd): Implementation of the new [dict
map] subcommand, based on (and sharing much of) [dict for].
* generic/tclCompCmds.c (TclCompileLmapCmd, TclCompileDictMapCmd):
Compilation engines for [lmap] and [dict map].
IMPLEMENTATION OF TIP#400
* generic/tclZlib.c: Allow the specification of a compression
dictionary (a binary blob used to seed the compression engine) in both
streams and channel transformations. Also some reorganization to allow
for getting gzip header dictionaries and controlling buffering levels
in channel transformations (allowing a trade-off between formal
correctness and speed).
(Tcl_ZlibStreamSetCompressionDictionary): New C API to allow setting
the compression dictionary without using a Tcl script.
2012-10-14 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclDictObj.c: [Bug 3576509]: ::tcl::Bgerror crashes with
* generic/tclEvent.c: invalid arguments. Better fix, which helps
for all Tcl_DictObjGet() calls in Tcl's source code.
2012-10-13 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclEvent.c: [Bug 3576509]: tcl::Bgerror crashes with invalid
arguments
2012-10-06 Jan Nijtmans <nijtmans@users.sf.net>
* win/Makefile.in: [Bug 2459774]: tcl/win/Makefile.in not compatible
with msys 0.8.
2012-10-03 Don Porter <dgp@users.sourceforge.net>
* generic/tclIO.c: When checking for std channels being closed,
compare the channel state, not the channel itself so that stacked
channels do not cause trouble.
2012-09-26 Reinhard Max <max@suse.de>
* generic/tclIOSock.c (TclCreateSocketAddress): Work around a bug in
getaddrinfo() on OSX that caused name resolution to fail for [socket
-server foo -myaddr localhost 0].
2012-09-20 Jan Nijtmans <nijtmans@users.sf.net>
* win/configure.in: New import libraries for zlib 1.2.7, usable for
* win/configure: all win32/win64 compilers
* compat/zlib/win32/zdll.lib:
* compat/zlib/win64/zdll.lib:
* win/tclWinDde.c: [FRQ 3527238]: Full unicode support for dde. Dde
version is now 1.4.0b2.
***POTENTIAL INCOMPATIBILITY***
2012-09-19 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tcl.h: Make Tcl_Interp a fully opaque structure if
TCL_NO_DEPRECATED is set (TIP 330 and 336).
* win/nmakehlp.c: Let "nmakehlp -V" start searching digits after the
found match (suggested by Harald Oehlmann).
2012-09-07 Harald Oehlmann <oehhar@users.sf.net>
*** 8.6b3 TAGGED FOR RELEASE ***
IMPLEMENTATION OF TIP#404.
* library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset]
* library/msgcat/pkgIndex.tcl: and [mcflmset] to set mc entries with
* unix/Makefile.in: implicit message file locale.
* win/Makefile.in: Bump to 1.5.0.
2012-08-25 Donal K. Fellows <dkf@users.sf.net>
* library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of
March in Ukrainian. Thanks to Mikhail Teterin for reporting.
2012-08-23 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclBinary.c: [Bug 3496014]: Unecessary memset() in
Tcl_SetByteArrayObj().
2012-08-20 Don Porter <dgp@users.sourceforge.net>
* generic/tclPathObj.c: [Bug 3559678]: Fix bad filename normalization
when the last component is the empty string.
2012-08-20 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinPort.h: Remove wrapper macro for ntohs(): unnecessary,
because it doesn't require an initialized winsock_2 library. See:
<http://msdn.microsoft.com/en-us/library/windows/desktop/ms740075%28v=vs.85%29.aspx>
* win/tclWinSock.c:
* generic/tclStubInit.c:
2012-08-17 Jan Nijtmans <nijtmans@users.sf.net>
* win/nmakehlp.c: Add "-V<num>" option, in order to be able to detect
partial version numbers.
2012-08-15 Jan Nijtmans <nijtmans@users.sf.net>
* win/buildall.vc.bat: Only build the threaded builds by default
* win/rules.vc: Some code cleanup
2010-08-13 Stuart Cassoff <stwo@users.sourceforge.net>
* unix/tclUnixCompat.c: [Bug 3555454]: Rearrange a bit to quash
'declared but never defined' compiler warnings.
2012-08-13 Jan Nijtmans <nijtmans@users.sf.net>
* compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use
* compat/zlib/win64/zdll.lib: it for the dynamic mingw-w64 build.
* win/Makefile.in:
* win/configure.in:
* win/configure:
2012-08-09 Reinhard Max <max@suse.de>
* tests/http.test: Fix http-3.29 for machines without IPv6 support.
2010-08-08 Stuart Cassoff <stwo@users.sourceforge.net>
* unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for
improved consistency within the file.
2012-08-08 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname
* tests/fileName.test: support
2012-08-07 Don Porter <dgp@users.sourceforge.net>
* generic/tclIOUtil.c: [Bug 3554250]: Overlooked one field of cleanup
in the thread exit handler for the filesystem subsystem.
2012-07-31 Donal K. Fellows <dkf@users.sf.net>
* generic/tclInterp.c (Tcl_GetInterpPath):
* unix/tclUnixPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd):
* win/tclWinPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd):
Purge use of Tcl_AppendElement, and corrected conversion of PIDs to
integer objects.
2012-07-31 Jan Nijtmans <nijtmans@users.sf.net>
* win/nmakehlp.c: Add -Q option from sampleextension.
* win/Makefile.in: [FRQ 3544967]: Missing objectfiles in static lib
* win/makefile.vc: (Thanks to Jos Decoster).
2012-07-29 Jan Nijtmans <nijtmans@users.sf.net>
* win/Makefile.in: No longer build tcltest.exe to run the tests,
but use tclsh86.exe in combination with tcltest86.dll to do that.
* tests/*.test: load tcltest86.dll if necessary.
2012-07-28 Jan Nijtmans <nijtmans@users.sf.net>
* tests/clock.test: [Bug 3549770]: Multiple test failures running
* tests/registry.test: tcltest outside build tree
* tests/winDde.test:
2012-07-27 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclUniData.c: Support Unicode 6.2 (Add Turkish lira sign)
* generic/regc_locale.c:
2012-07-25 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* win/tclWinPipe.c: [Bug 3547994]: Abandon the synchronous Windows
pipe driver to its fate when needed to honour TIP#398.
2012-07-24 Trevor Davel <twylite@crypt.co.za>
* win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file
descriptors for a socket where required (TcpCloseProc, SocketProc).
Refactor socket/descriptor setup to manage linked list operations in
one place. Fix memory leak in socket close (TcpCloseProc) and related
dangling pointers in SocketEventProc.
2012-07-19 Reinhard Max <max@suse.de>
* win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough
buffer for accept()ing IPv6 connections. Fix conversion of host and
port for passing to the accept proc to be independent of the IP
version.
2012-07-23 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclIO.c: [Bug 3545365]: Never try a bg-flush on a dead
channel, just like before 2011-08-17.
2012-07-19 Joe Mistachkin <joe@mistachkin.com>
* generic/tclTest.c: Fix several more missing mutex-locks in
TestasyncCmd.
2012-07-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclTest.c: [Bug 3544685]: Missing mutex-lock in
TestasyncCmd since 2011-08-19. Unbounded gratitude to Stuart
Cassoff for spotting it.
2012-07-17 Jan Nijtmans <nijtmans@users.sf.net>
* win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails
2012-07-16 Donal K. Fellows <dkf@users.sf.net>
* generic/tclUtil.c (UpdateStringOfEndOffset): [Bug 3544658]: Stop
1-byte overrun in memcpy, that object placement rules made harmless
but which still caused compiler complaints.
2012-07-16 Jan Nijtmans <nijtmans@users.sf.net>
* library/reg/pkgIndex.tcl: Make registry 1.3 package dynamically
loadable when ::tcl::pkgconfig is available.
2012-07-11 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinReg.c: [Bug 3362446]: registry keys command fails
with 8.5/8.6. Follow Microsofts example better in order to prevent
problems when using HKEY_PERFORMANCE_DATA.
2012-07-10 Jan Nijtmans <nijtmans@users.sf.net>
* unix/tclUnixNotfy.c: [Bug 3541646]: Don't panic on triggerPipe
overrun.
2012-07-10 Donal K. Fellows <dkf@users.sf.net>
* win/tclWinSock.c (InitializeHostName): Corrected logic that
extracted the name of the computer from the gethostname call so that
it would use the name on success, not failure. Also ensured that the
buffer size is exactly that recommended by Microsoft.
2012-07-08 Reinhard Max <max@suse.de>
* library/http/http.tcl: [Bug 3531209]: Add fix and test for URLs that
* tests/http.test: contain literal IPv6 addresses.
2012-07-05 Don Porter <dgp@users.sourceforge.net>
* unix/tclUnixPipe.c: [Bug 1189293]: Make "<<" binary safe.
* win/tclWinPipe.c:
2012-07-03 Donal K. Fellows <dkf@users.sf.net>
* generic/tclUtil.c (TclDStringAppendObj, TclDStringAppendDString):
* generic/tclInt.h (TclDStringAppendLiteral, TclDStringClear):
* generic/tclCompile.h (TclDStringAppendToken): Added wrappers to make
common cases of appending to Tcl_DStrings simpler to write. Prompted
by looking at [FRQ 1357401] (these are an _internal_ implementation of
that FRQ).
2012-06-29 Jan Nijtmans <nijtmans@users.sf.net>
* library/msgcat/msgcat.tcl: Add tn, ro_MO and ru_MO to msgcat.
2012-06-29 Harald Oehlmann <oehhar@users.sf.net>
* library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of
* library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump
* unix/Makefile.in: to 1.4.5
* win/Makefile.in:
2012-06-29 Donal K. Fellows <dkf@users.sf.net>
* doc/GetIndex.3: Reinforced the description of the requirement for
the tables of names to index over to be static, following posting to
tcl-core by Brian Griffin about a bug caused by Tktreectrl not obeying
this rule correctly. This does not represent a functionality change,
merely a clearer documentation of a long-standing constraint.
2012-06-26 Jan Nijtmans <nijtmans@users.sf.net>
* unix/tcl.m4: Let Cygwin shared build link with
* unix/configure.in: zlib1.dll, not cygz.dll (two less
* unix/configure: dependencies on cygwin-specific dll's)
* unix/Makefile.in:
2012-06-26 Reinhard Max <max@suse.de>
* generic/tclIOSock.c: Use EAI_SYSTEM only if it exists.
* unix/tclUnixSock.c:
2012-06-25 Don Porter <dgp@users.sourceforge.net>
* generic/tclFileSystem.h: [Bug 3024359]: Make sure that the
* generic/tclIOUtil.c: per-thread cache of the list of file systems
* generic/tclPathObj.c: currently registered is only updated at times
when no active loops are traversing it. Also reduce the amount of
epoch storing and checking to where it can make a difference.
2012-06-25 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdAH.c (EncodingDirsObjCmd): [Bug 3537605]: Do the right
thing when reporting errors with the number of arguments.
2012-06-25 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclfileName.c: [Patch 1536227]: Cygwin network pathname
* tests/fileName.test: support.
2012-06-23 Jan Nijtmans <nijtmans@users.sf.net>
* unix/tclUnixNotfy.c: [Bug 3508771]: Cygwin notifier for handling
win32 events.
2012-06-22 Reinhard Max <max@suse.de>
* generic/tclIOSock.c: Rework the error message generation of [socket],
* unix/tclUnixSock.c: so that the error code of getaddrinfo is used
* win/tclWinSock.c: instead of errno unless it is EAI_SYSTEM.
2012-06-21 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinReg.c: [Bug 3362446]: registry keys command fails
* tests/registry.test: with 8.5/8.6
2012-06-11 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: [Bug 3532959]: Make sure the lifetime
* generic/tclProc.c: management of entries in the linePBodyPtr
* tests/proc.test: hash table can tolerate either order of
teardown, interp first, or Proc first.
2012-06-08 Don Porter <dgp@users.sourceforge.net>
* unix/configure.in: Update autogoo for gettimeofday().
* unix/tclUnixPort.h: Thanks Joe English.
* unix/configure: autoconf 2.13
* unix/tclUnixPort.h: [Bug 3530533]: Centralize #include <pthread.h>
* unix/tclUnixThrd.c: in the tclUnixPort.h header so that old unix
systems that need inclusion in all compilation units are supported.
2012-06-08 Jan Nijtmans <nijtmans@users.sf.net>
* win/tclWinDde.c: Revise the "null data" check: null strings are
possible, but empty binary arrays are not.
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
* {win,unix}/configure{,.in}: [Bug 2812981]: Clean up bundled
packages' build directory from within Tcl's ./configure, to avoid
stale configuration.
2012-05-09 Andreas Kupries <andreask@activestate.com>
| | | | | | | | | | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 |
* {win,unix}/configure{,.in}: [Bug 2812981]: Clean up bundled
packages' build directory from within Tcl's ./configure, to avoid
stale configuration.
2012-05-09 Andreas Kupries <andreask@activestate.com>
* generic/tclIORChan.c: [Bug 3522560]: Fixed the crash, enabled the
test case. Modified [chan postevent] to properly inject the event(s)
into the owner thread's event queue for execution in the correct
context. Renamed the ForwardOpTo...Thread() function to match with our
terminology.
* tests/ioCmd.test: [Bug 3522560]: Added a test which crashes the core
if it were not disabled as knownBug. For a reflected channel
transfered to a different thread the [chan postevent] run in the
handler thread tries to execute the owner threads's fileevent scripts
by itself, wrongly reaching across thread boundaries.
2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclIO.c: Properly close nonblocking channels even when
not flushing them.
2012-05-03 Jan Nijtmans <nijtmans@users.sf.net>
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | 2012-04-27 Donal K. Fellows <dkf@users.sf.net> * library/init.tcl (auto_execok): Allow shell builtins to be detected even if they are upper-cased. 2012-04-26 Jan Nijtmans <nijtmans@users.sf.net> | | | | | | | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | 2012-04-27 Donal K. Fellows <dkf@users.sf.net> * library/init.tcl (auto_execok): Allow shell builtins to be detected even if they are upper-cased. 2012-04-26 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclStubInit.c: Get rid of _ANSI_ARGS_ and CONST * generic/tclIO.c: * generic/tclIOCmd.c: * generic/tclTest.c: * unix/tclUnixChan.c: 2012-04-25 Donal K. Fellows <dkf@users.sf.net> * generic/tclUtil.c (TclDStringToObj): Added internal function to make the fairly-common operation of converting a DString into an Obj a more efficient one; for long strings, it can just transfer the ownership of the buffer directly. Replaces this: |
| ︙ | ︙ | |||
316 317 318 319 320 321 322 | * win/tclWinInit.c: [Bug 3448512]: clock scan "1958-01-01" fails * win/tcl.m4: only in debug compilation. * win/configure: * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging. * unix/configure: * generic/tclBasic.c: | | | | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 | * win/tclWinInit.c: [Bug 3448512]: clock scan "1958-01-01" fails * win/tcl.m4: only in debug compilation. * win/configure: * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging. * unix/configure: * generic/tclBasic.c: * library/dde/pkgIndex.tcl: Use [::tcl::pkgconfig get debug] instead * library/reg/pkgIndex.tcl: of [info exists ::tcl_platform(debug)] 2012-04-10 Donal K. Fellows <dkf@users.sf.net> * generic/tcl.h (TCL_DEPRECATED_API): [Bug 2458976]: Added macro that can be used to mark parts of Tcl's API as deprecated. Currently only used for fields of Tcl_Interp, which TIPs 330 and 336 have deprecated with a migration strategy; we want to encourage people to move away |
| ︙ | ︙ | |||
350 351 352 353 354 355 356 | member of an ensemble. Thanks to Andreas Kupries for identifying that this was a problem case at all! (Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble information into [oo::copy]. 2012-04-04 Jan Nijtmans <nijtmans@users.sf.net> | | | | 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | member of an ensemble. Thanks to Andreas Kupries for identifying that this was a problem case at all! (Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble information into [oo::copy]. 2012-04-04 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs * generic/tclIOSock.c: platform implementation. * generic/tclInt.decls: * generic/tclIntDecls.h: * generic/tclStubInit.c: 2012-04-03 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclStubInit.c: Remove the TclpGetTZName implementation for |
| ︙ | ︙ | |||
407 408 409 410 411 412 413 | 2012-03-27 Jan Nijtmans <nijtmans@users.sf.net> * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW. * generic/tclFCmd.c: [Bug 2015723]: Duplicate inodes from file stat * generic/tclCmdAH.c: on windows (but now for cygwin as well). * generic/tclOODefineCmds.c: minor gcc warning * win/tclWinPort.h: Use lower numbers, preventing integer overflow. | | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 | 2012-03-27 Jan Nijtmans <nijtmans@users.sf.net> * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW. * generic/tclFCmd.c: [Bug 2015723]: Duplicate inodes from file stat * generic/tclCmdAH.c: on windows (but now for cygwin as well). * generic/tclOODefineCmds.c: minor gcc warning * win/tclWinPort.h: Use lower numbers, preventing integer overflow. Remove the workaround for mingw-w64 [Bug 3407992]. It's long fixed. 2012-03-27 Donal K. Fellows <dkf@users.sf.net> IMPLEMENTATION OF TIP#397. * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the target object name optional when copying classes. [RFE 3485060]: Add |
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | * generic/tclPlatDecls.h: a dummy TclWinCPUID) for Cygwin, so win32 * generic/tclStubInit.c: extensions using those can be loaded in * unix/tclUnixCompat.c: the cygwin version of tclsh. 2012-03-19 Venkat Iyer <venkat@comit.com> * library/tzdata/America/Atikokan: Update to tzdata2012b. | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 | * generic/tclPlatDecls.h: a dummy TclWinCPUID) for Cygwin, so win32 * generic/tclStubInit.c: extensions using those can be loaded in * unix/tclUnixCompat.c: the cygwin version of tclsh. 2012-03-19 Venkat Iyer <venkat@comit.com> * library/tzdata/America/Atikokan: Update to tzdata2012b. * library/tzdata/America/Blanc-Sablon: * library/tzdata/America/Dawson_Creek: * library/tzdata/America/Edmonton: * library/tzdata/America/Glace_Bay: * library/tzdata/America/Goose_Bay: * library/tzdata/America/Halifax: * library/tzdata/America/Havana: * library/tzdata/America/Moncton: * library/tzdata/America/Montreal: * library/tzdata/America/Nipigon: * library/tzdata/America/Rainy_River: * library/tzdata/America/Regina: * library/tzdata/America/Santiago: * library/tzdata/America/St_Johns: * library/tzdata/America/Swift_Current: * library/tzdata/America/Toronto: * library/tzdata/America/Vancouver: * library/tzdata/America/Winnipeg: * library/tzdata/Antarctica/Casey: * library/tzdata/Antarctica/Davis: * library/tzdata/Antarctica/Palmer: * library/tzdata/Asia/Yerevan: * library/tzdata/Atlantic/Stanley: * library/tzdata/Pacific/Easter: * library/tzdata/Pacific/Fakaofo: * library/tzdata/America/Creston: (new) 2012-03-19 Reinhard Max <max@suse.de> * unix/tclUnixSock.c (Tcl_OpenTcpServer): Use the values returned by getaddrinfo() for all three arguments to socket() instead of only using ai_family. Try to keep the most meaningful error while iterating over the result list, because using the last error can be misleading. 2012-03-15 Jan Nijtmans <nijtmans@users.sf.net> * generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin * unix/tclUnixFile.c: * unix/tclUnixPort.h: * win/cat.c: Remove cygwin stuff no longer needed * win/tclWinFile.c: * win/tclWinPort.h: 2012-03-12 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings 2012-03-11 Donal K. Fellows <dkf@users.sf.net> |
| ︙ | ︙ | |||
568 569 570 571 572 573 574 | caller might still overwrite, but we should at least avoid known-useless work.) 2012-02-29 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode * generic/tclEncoding.c: | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 | caller might still overwrite, but we should at least avoid known-useless work.) 2012-02-29 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode * generic/tclEncoding.c: * tests/source.test: 2012-02-23 Donal K. Fellows <dkf@users.sf.net> * tests/reg.test (14.21-23): Add tests relating to Bug 1115587. Actual bug is characterised by test marked with 'knownBug'. 2012-02-17 Jan Nijtmans <nijtmans@users.sf.net> |
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | fail if one timezone abbreviation was a proper tail of another, and zic used the same bytes of the file to represent both of them. Added a test case for the bug, using the same data that caused the observed failure "in the wild." 2011-12-30 Venkat Iyer <venkat@comit.com> | | | | | | | | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 | fail if one timezone abbreviation was a proper tail of another, and zic used the same bytes of the file to represent both of them. Added a test case for the bug, using the same data that caused the observed failure "in the wild." 2011-12-30 Venkat Iyer <venkat@comit.com> * library/tzdata/America/Bahia: Update to Olson's tzdata2011n * library/tzdata/America/Havana: * library/tzdata/Europe/Kiev: * library/tzdata/Europe/Simferopol: * library/tzdata/Europe/Uzhgorod: * library/tzdata/Europe/Zaporozhye: * library/tzdata/Pacific/Fiji: 2011-12-23 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] is wrong. * generic/tclUniData.c: * generic/regc_locale.c: * tests/utf.test: |
| ︙ | ︙ | |||
758 759 760 761 762 763 764 | * tools/uniParse.tcl: [Bug 3444754]: string tolower \u01c5 is wrong * generic/tclUniData.c: * tests/utf.test: 2011-11-30 Jan Nijtmans <nijtmans@users.sf.net> | | | < | | 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 | * tools/uniParse.tcl: [Bug 3444754]: string tolower \u01c5 is wrong * generic/tclUniData.c: * tests/utf.test: 2011-11-30 Jan Nijtmans <nijtmans@users.sf.net> * library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work when tclsh is compiled without using the setargv() function on mingw. 2011-11-29 Jan Nijtmans <nijtmans@users.sf.net> * win/Makefile.in: don't install tommath_(super)?class.h * unix/Makefile.in: don't install directories like 8.2 and 8.3 * generic/tclTomMath.h: [Bug 2991415]: move include tclInt.h from * generic/tclTomMathInt.h: tclTomMath.h to tclTomMathInt.h 2011-11-25 Donal K. Fellows <dkf@users.sf.net> * library/history.tcl (history): Simplify the dance of variable management used when chaining to the implementation command. 2011-11-22 Donal K. Fellows <dkf@users.sf.net> * generic/tclExecute.c (TclCompileObj): Simplify and de-indent the logic so that it is easier to comprehend. 2011-11-22 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinPort.h: [Bug 3354324]: Windows: [file mtime] sets wrong * win/tclWinFile.c: time (VS2005+ only). * generic/tclTest.c: 2011-11-20 Joe Mistachkin <joe@mistachkin.com> * tests/thread.test: Remove unnecessary [after] calls from the thread tests. Make error message matching more robust for tests that may |
| ︙ | ︙ | |||
868 869 870 871 872 873 874 | * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the time zone only if it was detected by one of the expensive methods. Otherwise after unsetting TCL_TZ or TZ the previous value will still be used. 2011-10-15 Venkat Iyer <venkat@comit.com> | | | | | 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 | * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the time zone only if it was detected by one of the expensive methods. Otherwise after unsetting TCL_TZ or TZ the previous value will still be used. 2011-10-15 Venkat Iyer <venkat@comit.com> * library/tzdata/America/Sitka: Update to Olson's tzdata2011l * library/tzdata/Pacific/Fiji: * library/tzdata/Asia/Hebron: (New) 2011-10-11 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinFile.c: [Bug 2935503]: Incorrect mode field returned by [file stat] command. 2011-10-09 Donal K. Fellows <dkf@users.sf.net> |
| ︙ | ︙ | |||
904 905 906 907 908 909 910 | * win/tclWinInt.h: Remove tclWinProcs, as it is no longer * win/tclWin32Dll.c: being used. 2011-10-03 Venkat Iyer <venkat@comit.com> * library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k | | | | | | | | | | | | 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 | * win/tclWinInt.h: Remove tclWinProcs, as it is no longer * win/tclWin32Dll.c: being used. 2011-10-03 Venkat Iyer <venkat@comit.com> * library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k * library/tzdata/Africa/Kampala: * library/tzdata/Africa/Nairobi: * library/tzdata/Asia/Gaza: * library/tzdata/Europe/Kaliningrad: * library/tzdata/Europe/Kiev: * library/tzdata/Europe/Minsk: * library/tzdata/Europe/Simferopol: * library/tzdata/Europe/Uzhgorod: * library/tzdata/Europe/Zaporozhye: * library/tzdata/Pacific/Apia: 2011-09-29 Donal K. Fellows <dkf@users.sf.net> * tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More refactoring so that more of the utility code is decently out of the way. Adjusted the header-material generator so that version numbers are only included in locations where there is room. |
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | * tests/ioCmd.test: by `make valgrind'. * unix/Makefile.in: 2011-09-16 Jan Nijtmans <nijtmans@users.sf.net> IMPLEMENTATION OF TIP #388 | | | | | | | | | | | 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 | * tests/ioCmd.test: by `make valgrind'. * unix/Makefile.in: 2011-09-16 Jan Nijtmans <nijtmans@users.sf.net> IMPLEMENTATION OF TIP #388 * doc/Tcl.n: * doc/re_syntax.n: * generic/regc_lex.c: * generic/regcomp.c: * generic/regcustom.h: * generic/tcl.h: * generic/tclParse.c: * tests/reg.test: * tests/utf.test: 2011-09-16 Donal K. Fellows <dkf@users.sf.net> * generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]: Corrected the handling of procedure error messages (found by TclOO). 2011-09-16 Jan Nijtmans <nijtmans@users.sf.net> |
| ︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 | * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Honolulu: * library/tzdata/Africa/Juba: (new) 2011-09-06 Jan Nijtmans <nijtmans@users.sf.net> * generic/tcl.h: [RFE 1711975]: Tcl_MainEx() (like Tk_MainEx()) | | | | 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 | * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Honolulu: * library/tzdata/Africa/Juba: (new) 2011-09-06 Jan Nijtmans <nijtmans@users.sf.net> * generic/tcl.h: [RFE 1711975]: Tcl_MainEx() (like Tk_MainEx()) * generic/tclDecls.h: * generic/tclMain.c: 2011-09-02 Don Porter <dgp@users.sourceforge.net> * tests/http.test: Convert [testthread] use to Thread package use. Eliminates memory leak seen in `make valgrind`. 2011-09-01 Alexandre Ferrieux <ferrieux@users.sourceforge.net> |
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 | 2011-08-18 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: [Bug 3096275]: Sync fcopy buffers input. 2011-08-18 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclUniData.c: [Bug 3393714]: Overflow in toupper delta | | | | 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 | 2011-08-18 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: [Bug 3096275]: Sync fcopy buffers input. 2011-08-18 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclUniData.c: [Bug 3393714]: Overflow in toupper delta * tools/uniParse.tcl: * tests/utf.test: 2011-08-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclIO.c: [Bug 2946474]: Consistently resume backgrounded * tests/ioCmd.test: flushes+closes when exiting. 2011-08-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net> |
| ︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 | * generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value. 2011-08-15 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclPosixStr.c: [Bug 3388350]: mingw64 compiler warnings * win/tclWinPort.h: | | | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 | * generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value. 2011-08-15 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclPosixStr.c: [Bug 3388350]: mingw64 compiler warnings * win/tclWinPort.h: * win/configure.in: * win/configure: 2011-08-14 Jan Nijtmans <nijtmans@users.sf.net> * doc/FindExec.3: [Patch 3124554]: Move WishPanic from Tk to Tcl * doc/Panic.3 Added Documentation 2011-08-12 Don Porter <dgp@users.sourceforge.net> |
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | * generic/tclCompCmds.c: [Bug 3386417]: Avoid a reference loop between * generic/tclInt.h: the bytecode and its companion errostack * generic/tclResult.c: when compiling a syntax error. 2011-08-09 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinConsole.c: [Bug 3388350]: mingw64 compiler warnings | | | | | 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 | * generic/tclCompCmds.c: [Bug 3386417]: Avoid a reference loop between * generic/tclInt.h: the bytecode and its companion errostack * generic/tclResult.c: when compiling a syntax error. 2011-08-09 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinConsole.c: [Bug 3388350]: mingw64 compiler warnings * win/tclWinDde.c: * win/tclWinPipe.c: * win/tclWinSerial.c: 2011-08-09 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclInt.h: Change the signature of TclParseHex(), such that * generic/tclParse.c: it can now parse up to 8 hex characters. 2011-08-08 Donal K. Fellows <dkf@users.sf.net> |
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 | * generic/tclUtil.c: rooting all growth routines by default on a common tunable parameter TCL_MIN_GROWTH. 2011-05-25 Don Porter <dgp@users.sourceforge.net> * library/msgcat/msgcat.tcl: Bump to msgcat 1.4.4. * library/msgcat/pkgIndex.tcl: | | | | 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 | * generic/tclUtil.c: rooting all growth routines by default on a common tunable parameter TCL_MIN_GROWTH. 2011-05-25 Don Porter <dgp@users.sourceforge.net> * library/msgcat/msgcat.tcl: Bump to msgcat 1.4.4. * library/msgcat/pkgIndex.tcl: * unix/Makefile.in: * win/Makefile.in: 2011-05-25 Donal K. Fellows <dkf@users.sf.net> * generic/tclOO.h (TCLOO_VERSION): Bump version. IMPLEMENTATION OF TIP#381. |
| ︙ | ︙ | |||
1983 1984 1985 1986 1987 1988 1989 | 2011-03-22 Miguel Sofer <msofer@users.sf.net> * generic/tclThreadAlloc.c: Simpler initialization of Cache under HAVE_FAST_TSD, from mig-alloc-reform. 2011-03-21 Jan Nijtmans <nijtmans@users.sf.net> | | | 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 | 2011-03-22 Miguel Sofer <msofer@users.sf.net> * generic/tclThreadAlloc.c: Simpler initialization of Cache under HAVE_FAST_TSD, from mig-alloc-reform. 2011-03-21 Jan Nijtmans <nijtmans@users.sf.net> * unix/tclLoadDl.c: [Bug 3216070]: Loading extension libraries * unix/tclLoadDyld.c: from embedded Tcl applications. ***POTENTIAL INCOMPATIBILITY*** For extensions which rely on symbols from other extensions being present in the global symbol table. For an example and some discussion of workarounds, see http://stackoverflow.com/q/8330614/301832 2011-03-21 Miguel Sofer <msofer@users.sf.net> |
| ︙ | ︙ | |||
2260 2261 2262 2263 2264 2265 2266 | 2011-01-25 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclPreserve.c: Don't miss 64-bit address bits in panic message. * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning * win/tclWinConsole.c: messages, e.g. by using full 64-bits for * win/tclWinDde.c: socket fd's | | | | | | | | | | | | | | | 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 | 2011-01-25 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclPreserve.c: Don't miss 64-bit address bits in panic message. * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning * win/tclWinConsole.c: messages, e.g. by using full 64-bits for * win/tclWinDde.c: socket fd's * win/tclWinPipe.c: * win/tclWinReg.c: * win/tclWinSerial.c: * win/tclWinSock.c: * win/tclWinThrd.c: 2011-01-19 Jan Nijtmans <nijtmans@users.sf.net> * tools/genStubs.tcl: [FRQ 3159920]: Tcl_ObjPrintf() crashes with * generic/tcl.decls bad format specifier. * generic/tcl.h: * generic/tclDecls.h: 2011-01-18 Donal K. Fellows <dkf@users.sf.net> * generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make sure that the cmdPtr field of the procPtr is correct and relevant at all times so that [info frame] can report sensible information about a frame after a return to it from a recursive call, instead of probably crashing (depending on what else has overwritten the Tcl stack!) 2011-01-18 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclBasic.c: Various mismatches between Tcl_Panic * generic/tclCompCmds.c: format string and its arguments, * generic/tclCompCmdsSZ.c: discovered thanks to [Bug 3159920] * generic/tclCompExpr.c: * generic/tclEnsemble.c: * generic/tclPreserve.c: * generic/tclTest.c: 2011-01-17 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclIOCmd.c: [Bug 3148192]: Commands "read/puts" incorrectly * tests/chanio.test: interpret parameters. Improved error-message * tests/io.test regarding legacy form. * tests/ioCmd.test |
| ︙ | ︙ | |||
2532 2533 2534 2535 2536 2537 2538 | quarantined at the front of the file and function headers follow the modern Tcl style. 2010-12-06 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclBinary.c: [Bug 3129448]: Possible over-allocation on * generic/tclCkalloc.c: 64-bit platforms. | | | 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 | quarantined at the front of the file and function headers follow the modern Tcl style. 2010-12-06 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclBinary.c: [Bug 3129448]: Possible over-allocation on * generic/tclCkalloc.c: 64-bit platforms. * generic/tclTrace.c: 2010-12-05 Jan Nijtmans <nijtmans@users.sf.net> * unix/tcl.m4: [Patch 3116490]: Cross-compile support for unix * unix/configure: (autoconf-2.59) 2010-12-03 Jeff Hobbs <jeffh@ActiveState.com> |
| ︙ | ︙ | |||
2668 2669 2670 2671 2672 2673 2674 | 2010-11-16 Jan Nijtmans <nijtmans@users.sf.net> * win/tclAppInit.c:Bring compilation under mingw-w64 a bit closer * win/cat.c: to reality. See for what's missing: * win/tcl.m4: <https://sourceforge.net/apps/trac/mingw-w64/wiki/Unicode%20apps> * win/configure: (re-generated) | | | 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 | 2010-11-16 Jan Nijtmans <nijtmans@users.sf.net> * win/tclAppInit.c:Bring compilation under mingw-w64 a bit closer * win/cat.c: to reality. See for what's missing: * win/tcl.m4: <https://sourceforge.net/apps/trac/mingw-w64/wiki/Unicode%20apps> * win/configure: (re-generated) * win/tclWinPort.h: [Bug 3110161]: Extensions using TCHAR don't compile on VS2005 SP1 2010-11-15 Andreas Kupries <andreask@activestate.com> * doc/interp.n: [Bug 3081184]: TIP #378. * doc/tclvars.n: Performance fix for TIP #280. * generic/tclBasic.c: |
| ︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 | * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl features to genStubs.tcl, partly: remove unneeded ifdeffery and put C++ guard around stubs pointer definition. * generic/*Decls.h: (regenerated) 2010-08-18 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: New redesign of [tailcall]: find * generic/tclExecute.c: errors early on, so that errorInfo * generic/tclInt.h: contains the proper info [Bug 3047235] * generic/tclNamesp.c: * generic/tclCmdAH.c (TclNRTryObjCmd): [Bug 3046594]: Block tailcalling out of the body of a non-bc'ed [try]. | > | 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 | * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl features to genStubs.tcl, partly: remove unneeded ifdeffery and put C++ guard around stubs pointer definition. * generic/*Decls.h: (regenerated) 2010-08-18 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: New redesign of [tailcall]: find * generic/tclExecute.c: errors early on, so that errorInfo * generic/tclInt.h: contains the proper info [Bug 3047235] * generic/tclNamesp.c: * generic/tclCmdAH.c (TclNRTryObjCmd): [Bug 3046594]: Block tailcalling out of the body of a non-bc'ed [try]. |
| ︙ | ︙ | |||
5037 5038 5039 5040 5041 5042 5043 | 2010-01-22 Donal K. Fellows <dkf@users.sf.net> * generic/tclExecute.c (TclExecuteByteCode): Improve error code generation from some of the tailcall-related bits of TEBC. 2010-01-21 Miguel Sofer <msofer@users.sf.net> | | | | 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 | 2010-01-22 Donal K. Fellows <dkf@users.sf.net> * generic/tclExecute.c (TclExecuteByteCode): Improve error code generation from some of the tailcall-related bits of TEBC. 2010-01-21 Miguel Sofer <msofer@users.sf.net> * generic/tclCompile.h: [Bug 2910748]: NRE-enable direct eval on BC * generic/tclExecute.c: spoilage. * tests/nre.test: 2010-01-19 Donal K. Fellows <dkf@users.sf.net> * doc/dict.n: [Bug 2929546]: Clarify just what [dict with] and [dict update] are doing with variables. |
| ︙ | ︙ | |||
6027 6028 6029 6030 6031 6032 6033 | * generic/tclTomMathInt.h (new): Public header tclTomMath.h had * generic/tclTomMath.h: dependence on private headers, breaking use * generic/tommath.h: by extensions [Bug 1941434]. 2009-10-05 Andreas Kupries <andreask@activestate.com> * library/safe.tcl (AliasGlob): Fixed conversion of catch to | | | | | | > | 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 | * generic/tclTomMathInt.h (new): Public header tclTomMath.h had * generic/tclTomMath.h: dependence on private headers, breaking use * generic/tommath.h: by extensions [Bug 1941434]. 2009-10-05 Andreas Kupries <andreask@activestate.com> * library/safe.tcl (AliasGlob): Fixed conversion of catch to try/finally, it had an 'on ok msg' branch missing, causing a silent error immediately, and bogus glob results, breaking search for Tcl modules. 2009-10-04 Daniel Steffen <das@users.sourceforge.net> * macosx/tclMacOSXBundle.c: [Bug 2569449]: Workaround CF memory * unix/tclUnixInit.c: managment bug in Mac OS X 10.4 & earlier. 2009-10-02 Kevin B. Kenny <kennykb@acm.org> * library/tzdata/Africa/Cairo: * library/tzdata/Asia/Gaza: * library/tzdata/Asia/Karachi: * library/tzdata/Pacific/Apia: Olson's tzdata2009n. |
| ︙ | ︙ | |||
6821 6822 6823 6824 6825 6826 6827 | * tests/httpd11.test: modes (normal, -channel and -handler) * makefiles: package version set to 2.8.0 2009-04-10 Daniel Steffen <das@users.sourceforge.net> * unix/tclUnixChan.c: TclUnixWaitForFile(): use FD_* macros * macosx/tclMacOSXNotify.c: to manipulate select masks (Cassoff). | | | | 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 | * tests/httpd11.test: modes (normal, -channel and -handler) * makefiles: package version set to 2.8.0 2009-04-10 Daniel Steffen <das@users.sourceforge.net> * unix/tclUnixChan.c: TclUnixWaitForFile(): use FD_* macros * macosx/tclMacOSXNotify.c: to manipulate select masks (Cassoff). [FRQ 1960647] [Bug 3486554] * unix/tclLoadDyld.c: Use RTLD_GLOBAL instead of RTLD_LOCAL. [Bug 1961211] * macosx/tclMacOSXNotify.c: revise CoreFoundation notifier to allow embedding into applications that already have a CFRunLoop running and want to run the tcl event loop via Tcl_ServiceModeHook(TCL_SERVICE_ALL). |
| ︙ | ︙ | |||
7019 7020 7021 7022 7023 7024 7025 | 2009-03-16 Donal K. Fellows <dkf@users.sf.net> * generic/tclCmdMZ.c (TryPostBody): [Bug 2688063]: Extract information from list before getting rid of last reference to it. 2009-03-15 Joe Mistachkin <joe@mistachkin.com> | | | < | 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 | 2009-03-16 Donal K. Fellows <dkf@users.sf.net> * generic/tclCmdMZ.c (TryPostBody): [Bug 2688063]: Extract information from list before getting rid of last reference to it. 2009-03-15 Joe Mistachkin <joe@mistachkin.com> * generic/tclThread.c: [Bug 2687952]: Modify fix for TSD leak to match * generic/tclThreadStorage.c: Tcl 8.5 (and prior) allocation semantics 2009-03-15 Donal K. Fellows <dkf@users.sf.net> * generic/tclThreadStorage.c (TSDTableDelete): [Bug 2687952]: Ensure * generic/tclThread.c (Tcl_GetThreadData): that structures in Tcl's TSD system are all freed. Use the correct matching allocator. |
| ︙ | ︙ | |||
7109 7110 7111 7112 7113 7114 7115 | is significantly improved by this change (according to the MAP collection of benchmarks in tclbench). Just in case there was some wisdom in the old ways that I missed, I left in the ability to restore the old patterns with a #define COMPAT 1 at the top of the file. 2009-02-20 Don Porter <dgp@users.sourceforge.net> | | | | | | 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 | is significantly improved by this change (according to the MAP collection of benchmarks in tclbench). Just in case there was some wisdom in the old ways that I missed, I left in the ability to restore the old patterns with a #define COMPAT 1 at the top of the file. 2009-02-20 Don Porter <dgp@users.sourceforge.net> * generic/tclPathObj.c: [Bug 2571597]: Fixed mistaken logic in * tests/fileName.test: TclFSGetPathType() that assumed (not "absolute") => "relative". This is a false assumption on Windows, where "volumerelative" is another possibility. 2009-02-18 Don Porter <dgp@users.sourceforge.net> * generic/tclStringObj.c: Simplify the logic of the Tcl_*SetObjLength() routines. * generic/tclStringObj.c: Rewrite GrowStringBuffer() so that it |
| ︙ | ︙ | |||
7166 7167 7168 7169 7170 7171 7172 | in ExtendStringRepWithUnicode. Use cheap checks to determine that no reallocation is necessary without cost of computing the precise number of bytes needed. Also make use of the string growth algortihm in the case of repeated appends. 2009-02-16 Jan Nijtmans <nijtmans@users.sf.net> | | | | | | | | | | 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 | in ExtendStringRepWithUnicode. Use cheap checks to determine that no reallocation is necessary without cost of computing the precise number of bytes needed. Also make use of the string growth algortihm in the case of repeated appends. 2009-02-16 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclZlib.c: Hack needed for official zlib1.dll build. * win/configure.in: fix [Feature Request 2605263] use official * win/Makefile.in: zlib build. * win/configure: (regenerated) * compat/zlib/zdll.lib: new files * compat/zlib/zlib1.dll: * win/Makefile.in: [Bug 2605232]: tdbc doesn't build when Tcl is compiled with --disable-shared. 2009-02-15 Don Porter <dgp@users.sourceforge.net> * generic/tclStringObj.c: [Bug 2603158]: Added protections from * generic/tclTestObj.c: invalid memory accesses when we append * tests/stringObj.test: (some part of) a Tcl_Obj to itself. Added the appendself and appendself2 subcommands to the [teststringobj] testing command and added tests to the test suite. * generic/tclStringObj.c: Factor out duplicate code from Tcl_AppendObjToObj. * generic/tclStringObj.c: Replace the 'size_t uallocated' field of the String struct, storing the number of bytes allocated to store the Tcl_UniChar array, with an 'int maxChars' field, storing the |
| ︙ | ︙ | |||
7318 7319 7320 7321 7322 7323 7324 | Simplify SetStringFromAny() by removing unreachable and duplicate code. Simplify Tcl_SetObjLength by removing unreachable code. Removed handling of (objPtr->bytes != NULL) from UpdateStringOfString, which is only called when objPtr->bytes is NULL. 2009-02-09 Jan Nijtmans <nijtmans@users.sf.net> | | | | | 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 | Simplify SetStringFromAny() by removing unreachable and duplicate code. Simplify Tcl_SetObjLength by removing unreachable code. Removed handling of (objPtr->bytes != NULL) from UpdateStringOfString, which is only called when objPtr->bytes is NULL. 2009-02-09 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclCompile.c: [Bug 2555129]: const compiler warning (as error) in tclCompile.c 2009-02-07 Donal K. Fellows <dkf@users.sf.net> * generic/tclZlib.c (TclZlibCmd): [Bug 2573172]: Ensure that when invalid subcommand name is given, the list of valid subcommands is produced. This gives a better experience when using the command interactively. 2009-02-05 Joe Mistachkin <joe@mistachkin.com> * generic/tclInterp.c: [Bug 2544618]: Fix argument checking for [interp cancel]. * unix/Makefile.in: Fix build issue with zlib on FreeBSD (and possibly other platforms). 2009-02-05 Donal K. Fellows <dkf@users.sf.net> * generic/tclCmdMZ.c (StringIndexCmd, StringRangeCmd, StringLenCmd): Simplify the implementation of some commands now that the underlying |
| ︙ | ︙ | |||
7353 7354 7355 7356 7357 7358 7359 | Part of scheme to address [Bug 1665628] by making the basic string operations more efficient on byte arrays. (Tcl_GetCharLength, Tcl_GetUniChar, Tcl_GetRange): More special casing work for bytearrays. 2009-02-04 Don Porter <dgp@users.sourceforge.net> | | | | | | | 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 | Part of scheme to address [Bug 1665628] by making the basic string operations more efficient on byte arrays. (Tcl_GetCharLength, Tcl_GetUniChar, Tcl_GetRange): More special casing work for bytearrays. 2009-02-04 Don Porter <dgp@users.sourceforge.net> * generic/tclStringObj.c: [Bug 2561794]: Added overflow protections to the AppendUtfToUtfRep routine to either avoid invalid arguments and crashes, or to replace them with controlled panics. * generic/tclCmdMZ.c: [Bug 2561746]: Prevent crashes due to int overflow of the length of the result of [string repeat]. 2009-02-03 Jan Nijtmans <nijtmans@users.sf.net> * macosx/tclMacOSXFCmd.c: Eliminate some unnessary type casts * unix/tclLoadDyld.c: some internal const decorations * unix/tclUnixCompat.c: spacing * unix/tclUnixFCmd.c |
| ︙ | ︙ | |||
7390 7391 7392 7393 7394 7395 7396 | * generic/tclObj.c (tclCmdNameType): [Bug 2558422]: Corrected the type of this structure so that extensions that write it (yuk!) will still be able to function correctly. 2009-02-03 Don Porter <dgp@users.sourceforge.net> | | | | | 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 | * generic/tclObj.c (tclCmdNameType): [Bug 2558422]: Corrected the type of this structure so that extensions that write it (yuk!) will still be able to function correctly. 2009-02-03 Don Porter <dgp@users.sourceforge.net> * generic/tclStringObj.c (SetUnicodeObj): [Bug 2561488]: Corrected failure of Tcl_SetUnicodeObj() to panic on a shared object. Also factored out common code to reduce duplication. * generic/tclObj.c (Tcl_GetStringFromObj): Reduce code duplication. 2009-02-02 Don Porter <dgp@users.sourceforge.net> * generic/tclInterp.c: Reverted the conversion of [interp] into an * tests/interp.test: ensemble. Such conversion is not necessary |
| ︙ | ︙ | |||
7467 7468 7469 7470 7471 7472 7473 | * generic/tclOODefineCmds.c (Tcl_ClassSetConstructor): [Bug 2531577]: Ensure that caches of constructor chains are cleared when the constructor is changed. 2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net> | | | | | | | | | 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 | * generic/tclOODefineCmds.c (Tcl_ClassSetConstructor): [Bug 2531577]: Ensure that caches of constructor chains are cleared when the constructor is changed. 2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * generic/tclInt.h: [Bug 1028264]: WSACleanup() too early. * generic/tclEvent.c: The fix introduces "late exit handlers" for * win/tclWinSock.c: similar late process-wide cleanups. 2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net> * win/tclWinSock.c: [Bug 2446662]: Resync Win behavior on RST with that of unix (EOF). 2009-01-26 Donal K. Fellows <dkf@users.sf.net> * generic/tclZlib.c (ChanClose): [Bug 2536400]: Only generate error messages in the interpreter when the thread is not being closed down. 2009-01-23 Donal K. Fellows <dkf@users.sf.net> * doc/zlib.n: Added a note that 'zlib push' is reversed by 'chan pop'. 2009-01-22 Jan Nijtmans <nijtmans@users.sf.net> |
| ︙ | ︙ | |||
7506 7507 7508 7509 7510 7511 7512 |
* unix/tcl.m4: Corrected a typo ($(SHLIB_VERSION) should be
${SHLIB_VERSION}).
* unix/configure: Autoconf 2.59
2009-01-21 Andreas Kupries <andreask@activestate.com>
| | | | | | | | | 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 |
* unix/tcl.m4: Corrected a typo ($(SHLIB_VERSION) should be
${SHLIB_VERSION}).
* unix/configure: Autoconf 2.59
2009-01-21 Andreas Kupries <andreask@activestate.com>
* generic/tclIORChan.c (ReflectClose): [Bug 2458202]:
* generic/tclIORTrans.c (ReflectClose): Closing a channel may supply
NULL for the 'interp'. Test for finalization needs to be different,
and one place has to pull the interp out of the channel instead.
2009-01-21 Don Porter <dgp@users.sourceforge.net>
* generic/tclStringObj.c: New fix for [Bug 2494093] replaces the
flawed attempt committed 2009-01-09.
2009-01-19 Kevin B. Kenny <kennykb@acm.org>
* unix/Makefile.in: [Patch 907924]:Added a CONFIG_INSTALL_DIR
* unix/tcl.m4: parameter so that distributors can control where
tclConfig.sh goes. Made the installation of 'ldAix' conditional upon
actually being on an AIX system. Allowed for downstream packagers to
customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart
Cassoff for his help.
* unix/configure: Autoconf 2.59
2009-01-19 David Gravereaux <davygrvy@pobox.com>
* win/build.vc.bat: Improved tools detection and error message
* win/makefile.vc: Reorganized the $(TCLOBJ) file list into seperate
parts for easier maintenance. Matched all sources built using -GL to
|
| ︙ | ︙ | |||
7560 7561 7562 7563 7564 7565 7566 | a Command when deleting it is important so that tests for certain classes of commands don't return false positives when applied to deleted command tokens. Overall change is now just replacement of a false comment with a true one. 2009-01-13 Jan Nijtmans <nijtmans@users.sf.net> | | | | 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 | a Command when deleting it is important so that tests for certain classes of commands don't return false positives when applied to deleted command tokens. Overall change is now just replacement of a false comment with a true one. 2009-01-13 Jan Nijtmans <nijtmans@users.sf.net> * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when using the native CC. * unix/configure (autoconf-2.59) 2009-01-13 Donal K. Fellows <dkf@users.sf.net> * generic/tclCmdMZ.c (Tcl_ThrowObjCmd): Move implementation of [throw] * library/init.tcl (throw): to C from Tcl. |
| ︙ | ︙ | |||
7584 7585 7586 7587 7588 7589 7590 | setting to NULL, since any extension following the advice of the old comment is going to be broken by NRE anyway, and needs to shift to flag-based testing (or stop intruding into such internal matters). Part of [Bug 2486550]. 2009-01-09 Don Porter <dgp@users.sourceforge.net> | | | | | | | | | | | | | | | | | | | | | | | | 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 |
setting to NULL, since any extension following the advice of the old
comment is going to be broken by NRE anyway, and needs to shift to
flag-based testing (or stop intruding into such internal matters).
Part of [Bug 2486550].
2009-01-09 Don Porter <dgp@users.sourceforge.net>
* generic/tclStringObj.c (STRING_SIZE): [Bug 2494093]: Corrected
failure to limit memory allocation requests to the sizes that can be
supported by Tcl's memory allocation routines.
2009-01-09 Donal K. Fellows <dkf@users.sf.net>
* generic/tclNamesp.c (NamespaceEnsembleCmd): [Bug 1558654]: Error out
when someone gives wrong # of args to [namespace ensemble create].
2009-01-08 Don Porter <dgp@users.sourceforge.net>
* generic/tclStringObj.c (STRING_UALLOC): [Bug 2494093]: Added missing
parens required to get correct results out of things like
STRING_UALLOC(num + append).
2009-01-08 Donal K. Fellows <dkf@users.sf.net>
* generic/tclDictObj.c, generic/tclIndexObj.c, generic/tclListObj.c,
* generic/tclObj.c, generic/tclStrToD.c, generic/tclUtil.c,
* generic/tclVar.c: Generate errorcodes for the error cases which
approximate to "I can't interpret that string as one of those" and
"You gave me the wrong number of arguments".
2009-01-07 Donal K. Fellows <dkf@users.sf.net>
* doc/dict.n: [Tk Bug 2491235]: Added more examples.
* tests/oo.test (oo-22.1): Adjusted test to be less dependent on the
specifics of how [info frame] reports general frame information, and
instead to focus on what methods add to it; that's really what the
test is about anyway.
2009-01-06 Don Porter <dgp@users.sourceforge.net>
* tests/stringObj.test: Revise tests that demand a NULL Tcl_ObjType
in certain values to construct those values with [testdstring] so
there's no lack of robustness depending on the shimmer history of
shared literals.
2009-01-06 Donal K. Fellows <dkf@users.sf.net>
* generic/tclDictObj.c (DictIncrCmd): Corrected twiddling in internals
of dictionaries so that literals can't get destroyed.
* tests/expr.test: [Bug 2006879]: Eliminate non-ASCII char.
* generic/tclOOInfo.c (InfoObjectMethodsCmd,InfoClassMethodsCmd):
[Bug 2489836]: Only delete pointers that were actually allocated!
* generic/tclOO.c (TclNRNewObjectInstance, Tcl_NewObjectInstance):
[Bug 2481109]: Perform search for existing commands in right context.
2009-01-05 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdMZ.c (TclNRSourceObjCmd): [Bug 2412068]: Make
* generic/tclIOUtil.c (TclNREvalFile): implementation of the
[source] command be NRE enabled so that [yield] inside a script
sourced in a coroutine can work.
2009-01-04 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdAH.c: Tidy up spacing and code style.
2009-01-03 Kevin B. Kenny <kennykb@acm.org>
* library/clock.tcl (tcl::clock::add): Fixed error message formatting
in the case where [clock add] is presented with a bad switch.
* tests/clock.test (clock-65.1) Added a test case for the above
problem [Bug 2481670].
2009-01-02 Donal K. Fellows <dkf@users.sf.net>
* unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 878333]: Force the use of the
compatibility version of mkstemp() on IRIX.
* unix/configure.in, unix/Makefile.in (mkstemp.o):
* compat/mkstemp.c (new file): [Bug 741967]: Added a compatibility
implementation of the mkstemp() function, which is apparently needed
on some platforms.
******************************************************************
*** CHANGELOG ENTRIES FOR 2008 IN "ChangeLog.2008" ***
*** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" ***
*** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" ***
*** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" ***
*** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" ***
*** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
*** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
******************************************************************
|
Changes to ChangeLog.2000.
| ︙ | ︙ | |||
742 743 744 745 746 747 748 | of a pipe before the child process, doesn't really fit the windows model. [BUG: 2460] 2000-09-07 Jeff Hobbs <hobbs@scriptics.com> * doc/trace.n: minor doc cleanup | | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 | of a pipe before the child process, doesn't really fit the windows model. [BUG: 2460] 2000-09-07 Jeff Hobbs <hobbs@scriptics.com> * doc/trace.n: minor doc cleanup 2000-09-06 André Pönitz <poenitz@htwm.de> * doc/*.n: added or changed "SEE ALSO:" section 2000-09-06 Jeff Hobbs <hobbs@scriptics.com> * win/tclWinLoad.c (TclpLoadFile): added special message for ERROR_PROC_NOT_FOUND exception in loading a dll. |
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 | a Windows system. 2000-07-17 Mo DeJong <mdejong@redhat.com> * unix/tcl.m4 (SC_ENABLE_GCC): Don't set CC=gcc before running AC_PROG_CC if CC is already set. | | | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 | a Windows system. 2000-07-17 Mo DeJong <mdejong@redhat.com> * unix/tcl.m4 (SC_ENABLE_GCC): Don't set CC=gcc before running AC_PROG_CC if CC is already set. 2000-07-13 André Pönitz <poenitz@mathematik.tu-chemnitz.de> * doc/lappend.n: * doc/lindex.n: * doc/linsert.n: * doc/list.n: * doc/llength.n: * doc/lrange.n: |
| ︙ | ︙ |
Changes to ChangeLog.2001.
| ︙ | ︙ | |||
935 936 937 938 939 940 941 | supported. Include instructions that indicate how to install Mingw and what URLs folks should use to download the supported version of Mingw. * win/configure: Regen. * win/configure.in: Error out if user tries to compile the Windows version of Tcl with Cygwin gcc. Users should compile with Mingw gcc instead. | | | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 | supported. Include instructions that indicate how to install Mingw and what URLs folks should use to download the supported version of Mingw. * win/configure: Regen. * win/configure.in: Error out if user tries to compile the Windows version of Tcl with Cygwin gcc. Users should compile with Mingw gcc instead. 2001-11-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> * generic/tclIO.c (ReadChars): Fixed [Bug 478856] reported by Stuart Cassoff <stwo@users.sourceforge.net>. The bug caused loss of fileevents when [read]ing less data from the channel than buffered. Due to an empty input buffer the flag CHANNEL_NEED_MORE_DATA was set but never reset, causing the I/O system to wait for more data instead of using a timer to synthesize fileevents and to flush the pending |
| ︙ | ︙ |
Changes to ChangeLog.2003.
| ︙ | ︙ | |||
3280 3281 3282 3283 3284 3285 3286 | and define HAVE_NO_LPFN_DECLS if not found. * win/tclWinSock.c: Define LPFN_* typedefs if HAVE_NO_LPFN_DECLS is defined. This fixes the build under Mingw and Cygwin, it was broken by the changes made on 2002-11-26. 2003-01-10 Vince Darley <vincentdarley@users.sourceforge.net> | | | 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 | and define HAVE_NO_LPFN_DECLS if not found. * win/tclWinSock.c: Define LPFN_* typedefs if HAVE_NO_LPFN_DECLS is defined. This fixes the build under Mingw and Cygwin, it was broken by the changes made on 2002-11-26. 2003-01-10 Vince Darley <vincentdarley@users.sourceforge.net> * generic/tclIOUtil.c: * win/tclWinInt.h: * win/tclWinInit.c: fix to new WinTcl crash on exit with vfs, introduced on 2002-12-06. Encodings must be cleaned up after the filesystem. * win/makefile.vc: fix to minor VC++ 5.2 syntax problem |
| ︙ | ︙ |
Changes to README.
1 | README: Tcl | | | 1 2 3 4 5 6 7 8 9 |
README: Tcl
This is the Tcl 8.6.0 source distribution.
http://tcl.sourceforge.net/
You can get any source release of Tcl from the file distributions
link at the above URL.
Contents
--------
1. Introduction
|
| ︙ | ︙ |
Changes to changes.
| ︙ | ︙ | |||
122 123 124 125 126 127 128 | ----------------- Released version 5.0 with Tk ------------------ 39. 4/3/91 Removed change bars from manual entries, leaving only those that came after version 3.3 was released. 40. 5/17/91 Changed tests to conform to Mary Ann May-Pumphrey's approach. | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | ----------------- Released version 5.0 with Tk ------------------ 39. 4/3/91 Removed change bars from manual entries, leaving only those that came after version 3.3 was released. 40. 5/17/91 Changed tests to conform to Mary Ann May-Pumphrey's approach. 41. 5/23/91 Massive revision to Tcl parser to simplify the implementation of string and floating-point support in expressions. Newlines inside [] are now treated as command separators rather than word separators (this makes newline treatment consistent throughout Tcl). *** POTENTIAL INCOMPATIBILITY *** 42. 5/23/91 Massive rewrite of expression code to support floating-point |
| ︙ | ︙ | |||
256 257 258 259 260 261 262 | added "info script" option. 71. 8/20/91 Changed "file" command to take "option" argument as first argument (before file name), for consistency with other Tcl commands. *** POTENTIAL INCOMPATIBILITY *** 72. 8/20/91 Changed format of information in $errorInfo variable: | | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
added "info script" option.
71. 8/20/91 Changed "file" command to take "option" argument as first
argument (before file name), for consistency with other Tcl commands.
*** POTENTIAL INCOMPATIBILITY ***
72. 8/20/91 Changed format of information in $errorInfo variable:
comments such as
("while" body line 1)
are now on separate lines from commands being executed.
*** POTENTIAL INCOMPATIBILITY ***
73. 8/20/91 Changed Tcl_AppendResult so that it (eventually) frees
large buffers that it allocates.
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 | TCL_DYNAMIC back to integer constants rather than procedure addresses. This was needed because procedure addresses can have multiple values under some dynamic loading systems (e.g. SunOS 4.1 and Windows). 6/8/95 (feature change) Modified interface to Tcl_Main to pass in the address of the application-specific initialization procedure. Tcl_AppInit is no longer hardwired into Tcl_Main. This is needed | | | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 | TCL_DYNAMIC back to integer constants rather than procedure addresses. This was needed because procedure addresses can have multiple values under some dynamic loading systems (e.g. SunOS 4.1 and Windows). 6/8/95 (feature change) Modified interface to Tcl_Main to pass in the address of the application-specific initialization procedure. Tcl_AppInit is no longer hardwired into Tcl_Main. This is needed in order to make Tcl a shared library. 6/8/95 (feature change) Modified Makefile so that the installed versions of tclsh and libtcl.a have version number in them (e.g. tclsh7.4 and libtcl7.4.a) and the library directory name also has an embedded version number (e.g., /usr/local/lib/tcl7.4). This should make it easier for Tcl 7.4 to coexist with earlier versions. |
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 | 1/23/96 (bug fix) Eliminated extremely long startup times under Windows '95. The problem was a result of the option database initialization code that concatenated $HOME with /.Xdefaults, resulting in a // in the middle of the file name. Under Windows '95, this is incorrectly interpreted as a UNC path. They delays came from the network timeouts needed to determine that the file name was invalid. Tcl_TranslateFileName now suppresses duplicate slashes that aren't at the beginning of the file name. (SS) | | | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 | 1/23/96 (bug fix) Eliminated extremely long startup times under Windows '95. The problem was a result of the option database initialization code that concatenated $HOME with /.Xdefaults, resulting in a // in the middle of the file name. Under Windows '95, this is incorrectly interpreted as a UNC path. They delays came from the network timeouts needed to determine that the file name was invalid. Tcl_TranslateFileName now suppresses duplicate slashes that aren't at the beginning of the file name. (SS) 1/25/96 (bug fix) Changed exec and open to create children so they are attached to the application's console if it exists. (SS) 1/31/96 (bug fix) Fixed command line parsing to handle embedded spaces under Windows. (SS) ----------------- Released 7.5b1, 2/1/96 ----------------------- |
| ︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 | 8/22/96 (new feature) Added a new memory allocator for the Macintosh version of Tcl. It's quite a bit faster than MetroWerk's version. (RJ) 8/26/96 (documentation update) Removed old change bars (for all changes in Tcl 7.5 and earlier releases) from manual entries. (JO) | | | | | | | 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 | 8/22/96 (new feature) Added a new memory allocator for the Macintosh version of Tcl. It's quite a bit faster than MetroWerk's version. (RJ) 8/26/96 (documentation update) Removed old change bars (for all changes in Tcl 7.5 and earlier releases) from manual entries. (JO) 8/27/96 (enhancement) The exec and open commands behave better and work in more situations under Windows NT and Windows 95. Documentation describes what is still lacking. (CS) 8/27/96 (enhancement) The Windows makefiles will now compile even if the compiler is not in the path and/or the compiler's environment variables have not been set up. (CS) 8/27/96 (configuration improvement) The Windows resource files are automatically updated when the version/patch level changes. The header file now has a comment that reminds the user which other files must be manually updated when the version/patch level changes. (CS) 8/28/96 (new feature) Added file manipulation features (copy, rename, delete, mkdir) that are supported on all platforms. They are implemented as subcommands to the "file" command. See the documentation for the "file" command for more information. (JH) ----------------- Released 7.6b1, 8/30/96 ----------------------- 9/3/96 (bug fix) Simplified code so that standard channels are created lazily, they are added to an interpreter lazily, and they are never added |
| ︙ | ︙ | |||
2367 2368 2369 2370 2371 2372 2373 |
10/2/96 (new feature) Improved the package loader:
- Added new variable tcl_pkgPath, which holds the default
directories under which packages are normally installed (each
package goes in a separate subdirectory of a directory in
$tcl_pkgPath). These directories are included in auto_path by
default.
| | | 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 |
10/2/96 (new feature) Improved the package loader:
- Added new variable tcl_pkgPath, which holds the default
directories under which packages are normally installed (each
package goes in a separate subdirectory of a directory in
$tcl_pkgPath). These directories are included in auto_path by
default.
- Changed the package auto-loader to look for pkgIndex.tcl files
not only in the auto_path directories but also in their immediate
children. This should make it easier to install and uninstall
packages (don't have to change auto_path or merge pkgIndex.tcl
files). (JO)
10/3/96 (bug fix) Changed tclsh to look for tclshrc.tcl instead of
tclsh.rc on startup under Windows. This is more consistent with wish and
|
| ︙ | ︙ | |||
2617 2618 2619 2620 2621 2622 2623 | of stat for current dir on c: drive. 1/10/97 (new feature) Added Tcl_GetIndexFromObj procedure for quick lookups of keyword arguments. (JO) 1/12/97 (new feature) Serial IO channel drivers for Windows and Unix, available by using Tcl open command to open pseudo-files like "com1:" or | | | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 | of stat for current dir on c: drive. 1/10/97 (new feature) Added Tcl_GetIndexFromObj procedure for quick lookups of keyword arguments. (JO) 1/12/97 (new feature) Serial IO channel drivers for Windows and Unix, available by using Tcl open command to open pseudo-files like "com1:" or "/dev/ttya". New option to Tcl fconfigure command for serial files: "-mode baud,parity,data,stop" to specify baud rate, parity, data bits, and stop bits. Serial IO is not yet available on Mac. 1/16/97 (feature change) Restored the Tcl7.x "two level substitution semantics" for expressions. Expressions not enclosed in braces are implemented, in general, by calling the expr command procedure (Tcl_ExprObjCmd) at runtime after the Tcl interpreter has already done a |
| ︙ | ︙ | |||
2697 2698 2699 2700 2701 2702 2703 | 2/4/97 (bug fix) Fixed bug in clock code that dealt with relative dates. Using the relative month code you could get an invalid date because it jumped into a non-existant day. (For example, Jan 31 to Feb 31.) The code now will return the last valid day of the month in these situations. Thanks to Hume Smith for sending in this bug fix. (RJ) | | | 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 | 2/4/97 (bug fix) Fixed bug in clock code that dealt with relative dates. Using the relative month code you could get an invalid date because it jumped into a non-existant day. (For example, Jan 31 to Feb 31.) The code now will return the last valid day of the month in these situations. Thanks to Hume Smith for sending in this bug fix. (RJ) 2/10/97 (feature change) Eliminated Tcl_StringObjAppend and Tcl_StringObjAppendObj procedures, replaced them with Tcl_AppendToObj and Tcl_AppendStringsToObj procedures. Added new procedure Tcl_SetObjLength. (JO) *** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2, but not with Tcl 7.6 *** 2/10/97 (new feature) Added Tcl_WrongNumArgs procedure for generating error messages about incorrect number of arguments. (JO) |
| ︙ | ︙ | |||
3064 3065 3066 3067 3068 3069 3070 |
- Command trace procedures would crash if they did a Tcl_EvalObj that
reallocated the evaluation stack.
- Break and continue commands did not reset the interpreter result.
- The Tcl_ExprXXX routines, both string- or object-based, always
modified the interpreter result even if there was no error.
- The argument parsing procedure used by several compile procedures
always treated "]" as end of a command: e.g., "set a ]" would fail.
| | | 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 |
- Command trace procedures would crash if they did a Tcl_EvalObj that
reallocated the evaluation stack.
- Break and continue commands did not reset the interpreter result.
- The Tcl_ExprXXX routines, both string- or object-based, always
modified the interpreter result even if there was no error.
- The argument parsing procedure used by several compile procedures
always treated "]" as end of a command: e.g., "set a ]" would fail.
- Changed errorInfo traceback message for compilation errors from
"invoked from within" to "while compiling".
- Problem initializing Tcl object managers during interpreter creation.
- Added check and error message if formal parameter to a procedure is
an array element. (BL)
6/23/97 (new feature) Added "registry" package to allow manipulation
of the Windows system registry. See manual entry for details. (SS)
|
| ︙ | ︙ | |||
3139 3140 3141 3142 3143 3144 3145 | of libraries in child process. (DL) 7/10/97 (bug fixes/new feature) Cleanup in Tcl_MakeSafe. Less information is leaked to safe interps. Error message fixes for interp sub commands. Likewise changes in safealias.tcl; tcl_safeCreateInterp can now be called without argument to generate the slave name (like in interp create). (DL) | | | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 | of libraries in child process. (DL) 7/10/97 (bug fixes/new feature) Cleanup in Tcl_MakeSafe. Less information is leaked to safe interps. Error message fixes for interp sub commands. Likewise changes in safealias.tcl; tcl_safeCreateInterp can now be called without argument to generate the slave name (like in interp create). (DL) 7/10/97 (bug fixes) Bytecode compiler now generates more detailed command location information: subcommands as well as commands now have location information. This means command trace procedures now get the correct source string for each command in their command parameter. (BL) 7/22/97 (bug fixes) Performance improvement in Safe interpreters handling. Added new mask value to (tclInt.h) Interp.flags record. (DL) |
| ︙ | ︙ | |||
3177 3178 3179 3180 3181 3182 3183 | both the Mac and Windows platforms to use the new allocator instead of malloc and free. (SS) 7/24/97 - 8/12/97 (bug fixes/change of features) Completely revamped safe sourcing/loading (see safe.n) to hide pathnames, use virtual paths tokens instead, improved security in several respects and made it more tunable. Multi level interp loading can work too now. Package auto | | | 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 | both the Mac and Windows platforms to use the new allocator instead of malloc and free. (SS) 7/24/97 - 8/12/97 (bug fixes/change of features) Completely revamped safe sourcing/loading (see safe.n) to hide pathnames, use virtual paths tokens instead, improved security in several respects and made it more tunable. Multi level interp loading can work too now. Package auto loading now works in safe interps as long as the package directory is in the auto_path (no deep crawling allowed in safe interps). (DL) *** POTENTIAL INCOMPATIBILITY with previous alpha and beta releases *** 7/24/97 (bug fixes) Made Tcl_SetVar* and Tcl_NewString* treat a NULL value as an empty string. (This fixes hairy crash case where you would crash because load command for other interps assumed presence of errorInfo...). (DL) |
| ︙ | ︙ | |||
3205 3206 3207 3208 3209 3210 3211 | destroyed if an error occurred when accessing them. In addition, the "info vars" command lists uninitialized namespace variables, while the "info exists" command returns 0 for them. (BL) 7/29/97 (feature change) Changed the http package to use the ::http namespace. http_get renamed to http::geturl, http_config renamed to http::config, http_formatQuery renamed to http::formatQuery. | | | 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 | destroyed if an error occurred when accessing them. In addition, the "info vars" command lists uninitialized namespace variables, while the "info exists" command returns 0 for them. (BL) 7/29/97 (feature change) Changed the http package to use the ::http namespace. http_get renamed to http::geturl, http_config renamed to http::config, http_formatQuery renamed to http::formatQuery. It now provides the 2.0 version of the package. The 1.0 version is still available with the old names. *** POTENTIAL INCOMPATIBILITY with Tcl 8.0b2 but not with Tcl 7.6 *** 7/29/97 (bug fix, new feature) Tcl_Main now uses Tcl objects internally to preserve NULLs in commands and command output. Added new API procedure Tcl_RecordAndEvalObj that resembles Tcl_RecordAndEval but takes an object containing a command. (BL) |
| ︙ | ︙ | |||
3269 3270 3271 3272 3273 3274 3275 | modify it). This makes the Tcl 8.0 behavior almost identical to 7.6 except that the default precision is 12 instead of 6. (JO) *** POTENTIAL INCOMPATIBILITY *** ----------------- Released 8.0, 8/18/97 ----------------------- 8/19/97 (bug fix) Minimal fix for glob -nocomplain bugs: | | | 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 | modify it). This makes the Tcl 8.0 behavior almost identical to 7.6 except that the default precision is 12 instead of 6. (JO) *** POTENTIAL INCOMPATIBILITY *** ----------------- Released 8.0, 8/18/97 ----------------------- 8/19/97 (bug fix) Minimal fix for glob -nocomplain bugs: "glob -nocomplain unreadableDir/*" was generating an anonymous error. More in depth fixes will come with 8.1. (DL). 8/20/97 (bug fix) Removed check for FLT_MIN in binary command so underflow conditions are handled by the compiler automatic conversions. (SS) 8/20/97 (bug fixes) Fixed several compilation-related bugs: |
| ︙ | ︙ | |||
3314 3315 3316 3317 3318 3319 3320 |
9/4/97 (bug fix) Slave interps now inherit the maximum recursion limit
of their parent instead of starting back at the default. {nb: this still
does not prevent stack overflow by multi-interps recursion or aliasing} (DL)
9/11/97 (bug fix) An uninitialized variable in Tcl_WaitPid caused
pipes to fail to report eof properly under Windows. (SS)
| | | 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 |
9/4/97 (bug fix) Slave interps now inherit the maximum recursion limit
of their parent instead of starting back at the default. {nb: this still
does not prevent stack overflow by multi-interps recursion or aliasing} (DL)
9/11/97 (bug fix) An uninitialized variable in Tcl_WaitPid caused
pipes to fail to report eof properly under Windows. (SS)
9/12/97 (bug fix) "exec" was misidentifying some DOS executables as not
executable. (CCS)
9/14/97 (bug fix) Was using the wrong structure in sizeof operation in
tclUnixChan.c. (JL)
9/15/97 (bug fix) Fixed notifier to break out of do-one-event loop if
Tcl_WaitForEvent returns 1, so that callers of Tcl_DoOneEvent will get
|
| ︙ | ︙ | |||
3338 3339 3340 3341 3342 3343 3344 | tests in socket.test that are not platform specific. (Thanks to Mark Roseman for the pointer on the fix.) (RJ) 9/18/97 (bug fix) Fixed bug -dictionary option of lsort that could cause the compare function to run off the end of an array if the number only contained 0's. (Thanks to Greg Couch for the report.) (RJ) | | | 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 |
tests in socket.test that are not platform specific. (Thanks to Mark
Roseman for the pointer on the fix.) (RJ)
9/18/97 (bug fix) Fixed bug -dictionary option of lsort that could
cause the compare function to run off the end of an array if the
number only contained 0's. (Thanks to Greg Couch for the report.) (RJ)
9/18/97 (bug fix) TclFinalizeEnvironment was not cleaning up
properly. (DL, JI)
9/18/97 (bug fix) Fixed long-standing bug where an "array get" command
did not trigger traces on the array or its elements. (BL)
9/18/97 (bug fixes) Fixed compilation-related bugs:
- Fixed errorInfo traceback information for toplevel coomands that
|
| ︙ | ︙ | |||
3374 3375 3376 3377 3378 3379 3380 | NULs in the joinString and in list elements after the 2nd one. Now you can "join $list \0" for instance. (DL) 10/9/97 (bug fix) Under windows, if env(TMP) or env(TEMP) referred to a non-existent directory, exec would fail when trying to create its temporary files. (CCS) | | | | 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 | NULs in the joinString and in list elements after the 2nd one. Now you can "join $list \0" for instance. (DL) 10/9/97 (bug fix) Under windows, if env(TMP) or env(TEMP) referred to a non-existent directory, exec would fail when trying to create its temporary files. (CCS) 10/9/97 (bug fix) Under mac and windows, "info hostname" would crash if sockets were installed but the hostname could not be determined anyhow. Tcl_GetHostName() was returning NULL when it should have been returning an empty string. (CCS) 10/10/97 (bug fix) "file attribute /" returned error on windows. (CCS) 10/10/97 (bug fix) Fixed the auto_load procedure to handle procedures defined in namespaces better. Also fixed pgk_mkIndex so it sees procedures defined in nested namespaces. Index entries are still only made for |
| ︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 | cause an error, which would cause the C code to attempt to close the now deleted channel. Bumping the refcount assures that the channel sticks around to be really closed in this case. (JL) 12/8/97 (bug fix) Need to protect the channel in a fileevent so that it is not deleted before the fileevent handler returns. (CS, JL) | | | 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 |
cause an error, which would cause the C code to attempt to close the
now deleted channel. Bumping the refcount assures that the channel sticks
around to be really closed in this case. (JL)
12/8/97 (bug fix) Need to protect the channel in a fileevent so that it
is not deleted before the fileevent handler returns. (CS, JL)
12/18/97 (bug fix) In the opt argument parsing package: if the description
had only flags, the "too many arguments" case was not detected. The default
value was not used for the special "args" ending argument. (DL)
1/15/98 (improvement) Moved common part of initScript in common file.
Moved windows specific initialization to init.tcl so you can initialize
Tcl in windows without having to call Tcl_Init which is now only
searching for init.tcl {back ported from 8.1}. (DL)
|
| ︙ | ︙ | |||
3507 3508 3509 3510 3511 3512 3513 | 6/18/98 (bug fix) The Windows registry package had a bad bounds check that could lead to a crash. (SS) 6/18/98 (bug fix) The foreach compile proc did not correctly handle non-local variable references. (SS) 6/25/98 (new features) Added name resolution hooks to support [incr Tcl]. | | | 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 | 6/18/98 (bug fix) The Windows registry package had a bad bounds check that could lead to a crash. (SS) 6/18/98 (bug fix) The foreach compile proc did not correctly handle non-local variable references. (SS) 6/25/98 (new features) Added name resolution hooks to support [incr Tcl]. There are new internal Tcl_*Resolver* APIs to add, query and remove the hooks. With this changes it should be possible to dynamically load [incr Tcl] as an extension. (MM) 7/1/97 (bug fix) The commands "info args, body, default, procs" did not correctly handle imported procedures. (RJ) 7/6/98 (improvement) pkg_mkIndex now implements the "package require" |
| ︙ | ︙ | |||
3535 3536 3537 3538 3539 3540 3541 | 6/4/98 (enhancement) Added new internal routines to support inserting and deleting from the stat, access, and open-file-channel mechanisms. TclAccessInsertProc, TclStatInsertProc, & TclOpenFileChannelInsertProc insert pointers to such routines; TclAccessDeleteProc, TclStatDeleteProc, & TclOpenFileChannelDeleteProc delete pointers to such routines. See the file generic/tclIOUtils.c for more details. (SKS) | | | 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 | 6/4/98 (enhancement) Added new internal routines to support inserting and deleting from the stat, access, and open-file-channel mechanisms. TclAccessInsertProc, TclStatInsertProc, & TclOpenFileChannelInsertProc insert pointers to such routines; TclAccessDeleteProc, TclStatDeleteProc, & TclOpenFileChannelDeleteProc delete pointers to such routines. See the file generic/tclIOUtils.c for more details. (SKS) 7/1/98 (enhancement) Added a new internal C variable tclPreInitScript. This is a pointer to a string that may hold an initialization script; If this pointer is non-NULL it is evaluated in Tcl_Init() prior to the built-in initialization script defined in the file generic/tclInitScript.h. (SKS) 7/6/98 (bug fix) Removed dead code in PlatformInitExitHandler so that |
| ︙ | ︙ | |||
3619 3620 3621 3622 3623 3624 3625 | Windows, MYDLLNAME.DLL was sourced, and mydllname.dll loaded. (EMS) 10/5/98 (new feature) Created a new Tcl_Obj type, "procbody". This object's internal representation holds a pointer to a Proc structure. Extended TclCreateProc to take both strings and "procbody". (EMS) 10/13/98 (bug fix) The "info complete" command can now handle strings | | | 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 | Windows, MYDLLNAME.DLL was sourced, and mydllname.dll loaded. (EMS) 10/5/98 (new feature) Created a new Tcl_Obj type, "procbody". This object's internal representation holds a pointer to a Proc structure. Extended TclCreateProc to take both strings and "procbody". (EMS) 10/13/98 (bug fix) The "info complete" command can now handle strings with NULLs embedded. Thanks to colin@field.medicine.adelaide.edu.au for providing this fix. (RJ) 10/13/98 (bug fix) The "lsort -dictionary" command did not properly handle some numbers starting with 0. Thanks to Richard Hipp <drh@acm.org> for submitting the fix to Scriptics. (RJ) 10/13/98 (bug fix) The function Tcl_SetListObj was creating an invalid |
| ︙ | ︙ | |||
3687 3688 3689 3690 3691 3692 3693 | script. [Bug id: 840] (RJ) 12/3/98 (bug fix) Windows NT creates sockets so they are inheritable by default. Fixed socket code so it turns off this bit right after creation so sockets aren't kept open by exec'ed processes. [Bug: 892] Thanks to Kevin Kenny for this fix. (SS) | | | 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 | script. [Bug id: 840] (RJ) 12/3/98 (bug fix) Windows NT creates sockets so they are inheritable by default. Fixed socket code so it turns off this bit right after creation so sockets aren't kept open by exec'ed processes. [Bug: 892] Thanks to Kevin Kenny for this fix. (SS) 1/11/98 (bug fix) On HP, "info sharedlibextension" was returning empty string on static apps. It now always returns ".sl". (RJ) 1/28/99 (configure change) Now support -pipe option on gcc. (RJ) 2/2/99 (bug fix) Fixed initialization problem on Windows where no searching for init.tcl would be performed if the registry keys were missing. (stanton) |
| ︙ | ︙ | |||
3732 3733 3734 3735 3736 3737 3738 | socket.n manual entry for details. (stanton) 2/2/99 (bug fix) Deleting a renamed interp alias could result in a panic. (stanton) 2/2/99 (feature change/bug fix) Changed the behavior of "file extension" so that it splits at the last period. Now the extension of | | | | | | 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 |
socket.n manual entry for details. (stanton)
2/2/99 (bug fix) Deleting a renamed interp alias could result in a
panic. (stanton)
2/2/99 (feature change/bug fix) Changed the behavior of "file
extension" so that it splits at the last period. Now the extension of
a file like "foo..o" is ".o" instead of "..o" as in previous versions.
*** POTENTIAL INCOMPATIBILITY ***
----------------- Released 8.0.5, 3/9/99 -------------------------
======== Changes for 8.0 go above this line ========
======== Changes for 8.1 go below this line ========
6/18/97 (new feature) Tcl now supports international character sets:
- All C APIs now accept UTF-8 strings instead of iso8859-1 strings,
wherever you see "char *", unless explicitly noted otherwise.
- All Tcl strings represented in UTF-8, which is a convenient
multi-byte encoding of Unicode. Variable names, procedure names,
and all other values in Tcl may include arbitrary Unicode characters.
For example, the Tcl command "string length" returns how many
Unicode characters are in the argument string.
- For Java compatibility, embedded null bytes in C strings are
represented as \xC080 in UTF-8 strings, but the null byte at the end
of a UTF-8 string remains \0. Thus Tcl strings once again do not
contain null bytes, except for termination bytes.
- For Java compatibility, "\uXXXX" is used in Tcl to enter a Unicode
character. "\u0000" through "\uffff" are acceptable Unicode
characters.
- "\xXX" is used to enter a small Unicode character (between 0 and 255)
in Tcl.
- Tcl automatically translates between UTF-8 and the normal encoding for
the platform during interactions with the system.
- The fconfigure command now supports a -encoding option for specifying
the encoding of an open file or socket. Tcl will automatically
translate between the specified encoding and UTF-8 during I/O.
See the directory library/encoding to find out what encodings are
supported (eventually there will be an "encoding" command that
makes this information more accessible).
- There are several new C APIs that support UTF-8 and various encodings.
See Utf.3 for procedures that translate between Unicode and UTF-8
and manipulate UTF-8 strings. See Encoding.3 for procedures that
create new encodings and translate between encodings. See
|
| ︙ | ︙ | |||
3835 3836 3837 3838 3839 3840 3841 | "info args", "info body", and "info default" to return information about imported procedures as well as procedures defined in a namespace. (BL) 12/19/97 (enhancement) Added new Tcl_GetString() procedure that can be used in place of Tcl_GetStringFromObj() if the string representation's length isn't needed. (BL) | | | | | 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 | "info args", "info body", and "info default" to return information about imported procedures as well as procedures defined in a namespace. (BL) 12/19/97 (enhancement) Added new Tcl_GetString() procedure that can be used in place of Tcl_GetStringFromObj() if the string representation's length isn't needed. (BL) 12/18/97 (bug fix) In the opt argument parsing package: if the description had only flags, the "too many arguments" case was not detected. The default value was not used for the special "args" ending argument. (DL) 1/7/98 (clean up) Moved everything not absolutly necessary out of init.tcl procs now in auto.tcl and package.tcl can be autoloaded if needed. (DL) 1/7/98 (enhancement) tcltest made at install time will search for it's init.tcl where it is, even when using virtual path compilation. (DL) 1/8/98 (os bug workaround) when needed, using a replacement for memcmp so string compare "char with high bit set" "char w/o high bit set" returns the expected value on all platforms. (DL) 1/8/98 (unix portability/configure) building from .../unix/targetName/ subdirectories and simply using "../configure" should now work fine. (DL) 1/14/98 (enhancement) Added new regular expression package that supports AREs, EREs, and BREs. The new package includes new escape characters, meta-syntax, and character classes inside brackets. Regexps involving backslashes may behave differently. (MH) *** POTENTIAL INCOMPATIBILITY *** |
| ︙ | ︙ | |||
3881 3882 3883 3884 3885 3886 3887 | ----------------- Released 8.1a1, 1/22/98 ----------------------- 1/28/98 (new feature) Added a "-direct" optional flag to pkg_mkIndex to generate direct loading package indexes (such those you need if you use namespaces and plan on using namespace import just after package require). pkg_mkIndex still has limitations regarding package dependencies but errors are now ignored and with -direct, correct | | | 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 | ----------------- Released 8.1a1, 1/22/98 ----------------------- 1/28/98 (new feature) Added a "-direct" optional flag to pkg_mkIndex to generate direct loading package indexes (such those you need if you use namespaces and plan on using namespace import just after package require). pkg_mkIndex still has limitations regarding package dependencies but errors are now ignored and with -direct, correct package indexes can be generated even if there are dependencies as long as the "package provide" are done early enough in the files. (DL) 1/28/98 (enhancement) Performance tuning of regexp and regsub. (CCS) 1/28/98 (bug fix) regexp and regsub with "-indices" returned the byte-offsets of the characters in the UTF-8 representation, not the character offsets themselves. (CCS) |
| ︙ | ︙ | |||
3905 3906 3907 3908 3909 3910 3911 | 1/28/98 (bug fix) Tcl_OpenCommandChannel() was modifying the contents of the argv array passed to it, causing problems for any caller that wanted to continue to use the argv array after calling Tcl_OpenCommandChannel(). (CCS) 2/1/98 (bug fix) More bugs with %Z in format string argument to strftime(): 1. Borland always returned empty string. 2. MSVC always returned the timezone string for the current time, not the | | | 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 | 1/28/98 (bug fix) Tcl_OpenCommandChannel() was modifying the contents of the argv array passed to it, causing problems for any caller that wanted to continue to use the argv array after calling Tcl_OpenCommandChannel(). (CCS) 2/1/98 (bug fix) More bugs with %Z in format string argument to strftime(): 1. Borland always returned empty string. 2. MSVC always returned the timezone string for the current time, not the timezone string for the specified time. 3. With MSVC, "clock format 0 -format %Z -gmt 1" would return "GMT" the first time it was called, but would return the current timezone string on all subsequent calls. (CCS) 2/1/98 (bug fix) "file stat" was broken on Windows. 1. "file stat" of a root directory (local or network) or a relative path that resolved to a root directory (c:. when in pwd was c:/) was returning error. |
| ︙ | ︙ | |||
3927 3928 3929 3930 3931 3932 3933 | 2/1/98 (bug fix) "file attributes" of a relative path that resolved to a root directory was returning error. (CCS) 2/1/98 (bug fix) Change error message when "file attribute" could not determine the attributes for a file. Previously it would return different error messages on Unix vs. Windows vs. Mac. (CCS) | | | | | | | | 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 |
2/1/98 (bug fix) "file attributes" of a relative path that resolved to a
root directory was returning error. (CCS)
2/1/98 (bug fix) Change error message when "file attribute" could not
determine the attributes for a file. Previously it would return different
error messages on Unix vs. Windows vs. Mac. (CCS)
2/4/98 (bug fixes) Fixed several instances of bugs where the parser/compiler
would reach outside the range of allocated memory. Improved the array
lookup algorithm in set compilation. (DL)
2/5/98 (change) The TCL_PARSE_PART1 flag for Set/Get(Obj)Var2 C APIs is now
deprecated and ignored. The part1 is always parsed when the part2 argument
is NULL. This is to avoid a pattern of errors for extension writers converting
from string based Tcl_SetVar() to new Tcl_SetObjVar2() and who could easily
forget to provide the flag and thus get code working for normal variables
but not for array elements. The performance hit is minimal. A side effect
of that change is that is is no longer possible to create scalar variables
that can't be accessed by tcl scripts because of their invalid name
(ending with parenthesis). Likewise it is also parsed and checked to
ensure that you don't create array elements of array whose name is a valid
array element because they would not be accessible from scripts anyway.
Note: There is still duplicate array elements parsing code. (DL)
*** POTENTIAL INCOMPATIBILITY ***
2/11/98 (bug fix) Sharing objects between interps, such as by "interp
eval" or "send" could cause a crash later when dereferencing an interp
that had been deleted, given code such as:
set a {set x y}
|
| ︙ | ︙ | |||
3987 3988 3989 3990 3991 3992 3993 | 2/11/98 (bug fix) Windows "registry" command was dereferencing uninitialized memory when constructing the $errorCode for a failed registry call. (CCS) 2/11/98 (enhancement) Eliminate the TCL_USE_TIMEZONE_VAR definition from configure.in, because it was the same information as the already existing HAVE_TM_ZONE definition. The lack of HAVE_TM_ZONE is used to work around a | | | 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 | 2/11/98 (bug fix) Windows "registry" command was dereferencing uninitialized memory when constructing the $errorCode for a failed registry call. (CCS) 2/11/98 (enhancement) Eliminate the TCL_USE_TIMEZONE_VAR definition from configure.in, because it was the same information as the already existing HAVE_TM_ZONE definition. The lack of HAVE_TM_ZONE is used to work around a Solaris and Windows bug where "clock format [clock sec] -format %Z -gmt 1" produces the local timezone string instead of "GMT". (CCS) 2/11/98 (bug fix) Memleaks and dereferencing of uninitialized memory in regexp if an error occurred while compiling a regular expression. (CCS). 2/18/98 (new feature) Added mutexes and thread local storage in order to make Tcl thread safe. For testing purposes, there is a testthread |
| ︙ | ︙ | |||
4345 4346 4347 4348 4349 4350 4351 | in a duplicated Tcl_Obj. [Bug: 1975, 2047] (stanton) 5/3/99 (bug fix) Changed Tcl_ParseCommand to avoid modifying eval'ed strings that are already null terminated. [Bug: 1793] (stanton) 5/3/99 (new feature) Applied Jeff Hobbs's string patch which includes the following changes: | | | 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 |
in a duplicated Tcl_Obj. [Bug: 1975, 2047] (stanton)
5/3/99 (bug fix) Changed Tcl_ParseCommand to avoid modifying eval'ed
strings that are already null terminated. [Bug: 1793] (stanton)
5/3/99 (new feature) Applied Jeff Hobbs's string patch which includes
the following changes:
- added new subcommands: equal, repeat, map, is, replace
- added -length option to "string compare|equal"
- added -nocase option to "string compare|equal|match"
- string and list indices can be an integer or end?-integer?.
- added optional first and last index args to string toupper, et al.
See the string.n manual entry for more details about the new string
features. [Bug: 1845] (stanton)
|
| ︙ | ︙ | |||
4374 4375 4376 4377 4378 4379 4380 | interpreter. This set of changes should provide significant speed improvements for many Tcl scripts. [Bug: 1063] (stanton) 5/14/99 (bug fix) Durining initialization on Unix, Tcl now extracts the encoding subfield from the LANG/LC_ALL environment variables in cases where the locale is not found in the built-in locale table. It also attempts to initialize the locale subsystem so X11 is happy. [Bug: 1989] | | | 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 | interpreter. This set of changes should provide significant speed improvements for many Tcl scripts. [Bug: 1063] (stanton) 5/14/99 (bug fix) Durining initialization on Unix, Tcl now extracts the encoding subfield from the LANG/LC_ALL environment variables in cases where the locale is not found in the built-in locale table. It also attempts to initialize the locale subsystem so X11 is happy. [Bug: 1989] (stanton) 5/14/99 (bug fix) Applied the patch to fix 100-year and 400-year boundaries in leap year code, from Isaac Hollander. [Bug: 2066] (redman) 5/14/99 (bug fix) Fixed a crash caused by a failure to reset the result before evaluating the test expression in an uncompiled for statement. (stanton) |
| ︙ | ︙ | |||
4462 4463 4464 4465 4466 4467 4468 | 6/25/99 (new feature) Added initial implementation of new Tcl test harness package. Modified test files to use new tcltest package. (jenn) 6/26/99 (new feature) Applied patch from Peter Hardie to add poke command to dde and changed the dde package version number to | | | 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 | 6/25/99 (new feature) Added initial implementation of new Tcl test harness package. Modified test files to use new tcltest package. (jenn) 6/26/99 (new feature) Applied patch from Peter Hardie to add poke command to dde and changed the dde package version number to 1.1. (redman) 6/28/99 (bug fix) Applied patch from Peter Hardie to fix problem in Tcl_GetIndexFromObj() when the key being passed is the empty string. [Bug: 1738] (redman) 6/29/99 (new feature) Added options to tcltest package: -preservecore, -limitconstraints, -help, -file, -notfile, and flags. (jenn) |
| ︙ | ︙ | |||
4525 4526 4527 4528 4529 4530 4531 | checked for fileevents. Also added documentation for \\.\comX notation for opening serial ports on Windows. (redman) 7/21/99 (bug fix) Changed APIs in stub tables to use "unsigned long" instead of the platform-specific "size_t", primarily after SunOS 4 users could no longer compile. (redman) | | | 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 |
checked for fileevents. Also added documentation for \\.\comX
notation for opening serial ports on Windows. (redman)
7/21/99 (bug fix) Changed APIs in stub tables to use "unsigned long"
instead of the platform-specific "size_t", primarily after SunOS 4
users could no longer compile. (redman)
7/22/99 (bug fix) Fixed crashing during "array set a(b) {}".
[Bug: 2427] (redman)
7/22/99 (bug fix) The install-sh script must be given execute
permissions prior to running. [Bug: 2413] (redman)
7/22/99 (bug fix) Applied patch from Ulrich Ring to remove ANSI-style
prototypes in the code. [Bug: 2391] (redman)
|
| ︙ | ︙ | |||
4560 4561 4562 4563 4564 4565 4566 | 7/29/99 (bug fix) Applied patch to fix typo in .SH NAME line in doc/Encoding.n [Bug: 2451]. Applied patch to avoid linking pack.n to pack-old.n [Bug: 2469]. Patches from Don Porter. (redman) 7/29/99 (bug fix) Allow tcl to open CON and NUL, even for redirection of std channels. [Bug: 2393 2392 2209 2458] (redman) | | | | | | 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 | 7/29/99 (bug fix) Applied patch to fix typo in .SH NAME line in doc/Encoding.n [Bug: 2451]. Applied patch to avoid linking pack.n to pack-old.n [Bug: 2469]. Patches from Don Porter. (redman) 7/29/99 (bug fix) Allow tcl to open CON and NUL, even for redirection of std channels. [Bug: 2393 2392 2209 2458] (redman) 7/30/99 (bug fix) Applied fixed Trf patch from Andreas Kupries. [Bug: 2386] (hobbs) 7/30/99 (bug fix) Fixed bug in info complete. [Bug: 2383 2466] (hobbs) 7/30/99 (bug fix) Applied patch to fix threading on Irix 6.5, patch provided by James Dennett. [Bug: 2450] (redman) 7/30/99 (bug fix) Fixed launching of 16bit applications on Win9x from wish. The command line was being primed with tclpip82.dll, but it was ignored later. 7/30/99 (bug fix) Added functions to stub table, patch provided by Jan Nijtmans. [Bug: 2445] (hobbs) 8/1/99 (bug fix) Changed Windows socket driver to terminate threads by sending a message to the window rather than calling TerminateThread(), which seems to leak about 4k from the helper thread's stack space. (redman) --------------- Released 8.2b2, August 5, 1999 ---------------------- 8/4/99 (bug fix) Applied patches supplied by Henry Spencer to greatly enhance performance of certain classes of regular expressions. [Bug: 2440 2447] (stanton) 8/5/99 (doc change) Made it clear that tcl_pkgPath was not set for Windows. [Bug: 2455] (hobbs) 8/5/99 (bug fix) Fixed reference to bytes that might not be null terminated in tclLiteral.c. [Bug: 2496] (hobbs) 8/5/99 (bug fix) Fixed typo in http.tcl. [Bug: 2502] (hobbs) 8/9/99 (bug fix) Fixed test suite to handle larger integers (64bit). Patch from Don Porter. (hobbs) 8/9/99 (documentation fix) Clarified Tcl_DecrRefCount docs [Bug: 1952]. Clarified array pattern docs [Bug: 1330]. Fixed clock docs [Bug: 693]. Fixed formatting errors [Bug: 2188 2189]. Fixed doc error in tclvars.n [Bug: 2042]. (hobbs) 8/9/99 (bug fix) Fixed path handling in auto_execok [Bug: 1276] (hobbs) 8/9/99 (internal api change) Removed the TclpMutexLock and TclpMutexUnlock |
| ︙ | ︙ | |||
4657 4658 4659 4660 4661 4662 4663 | 10/30/99 (bug fix) fixed Purify reported memory leaks in findexecutable test command, TclpCreateProcess on Unix, in handling of C environ array, and in testthread code. No more known (reported) mem leaks for Tcl built using gcc on Solaris 2.5.1. Also none reported for Tcl on NT (using Purify 6.0). (hobbs) | | | 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 |
10/30/99 (bug fix) fixed Purify reported memory leaks in findexecutable
test command, TclpCreateProcess on Unix, in handling of C environ array,
and in testthread code. No more known (reported) mem leaks for Tcl
built using gcc on Solaris 2.5.1. Also none reported for Tcl on NT
(using Purify 6.0). (hobbs)
10/30/99 (bug fix) fixed improper bytecode handling of
'eval {set array($unknownvar) 5}' (also for incr) (hobbs)
10/30/99 (bug fix) fixed event/io threading problems by making
triggerPipe non-blocking (nick kisserbeth)
10/30/99 (bug fix) fixed Tcl_AppendStringsToObjVA and Tcl_AppendResultVA
to only iterates once over the va_list (avoiding non-portable memcpy).
|
| ︙ | ︙ | |||
5111 5112 5113 5114 5115 5116 5117 | 2001-05-27 (new feature) updated to Unicode 3.1.0 data set (still using 16 bits for Tcl_UniChar though) (hobbs) 2001-05-30 (new feature)[TIP 15] Tcl_GetMathFuncInfo, Tcl_ListMathFuncs, Tcl_InfoObjCmd, InfoFunctionsCmd APIs (fellows) | | | 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 |
2001-05-27 (new feature) updated to Unicode 3.1.0 data set (still using 16
bits for Tcl_UniChar though) (hobbs)
2001-05-30 (new feature)[TIP 15] Tcl_GetMathFuncInfo, Tcl_ListMathFuncs,
Tcl_InfoObjCmd, InfoFunctionsCmd APIs (fellows)
2001-06-08 (bug fix,feature enhancement)[219170,414936] all Tcl_Panic
definitions brought into agreement (porter)
2001-06-12 (bug fix)[219232] regexp returned non-matching sub-pairs to have
index pair {-1 -1} (fellows)
2001-06-27 (bug fix)[217987] corrected backslash substitution of non-ASCII
characters. (hobbs, riefenstahl)
|
| ︙ | ︙ | |||
5280 5281 5282 5283 5284 5285 5286 |
2001-09-10 (performance enhancement)[TIP 53,451441] [proc foo args {}] now
compiles to 0 bytecodes (sofer)
2001-09-13 (new feature)[TIP 56] Tcl_EvalTokensStandard API (sofer)
2001-09-13 (new feature) Old ChangeLog entries => ChangeLog.1999 (hobbs)
| | | 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 |
2001-09-10 (performance enhancement)[TIP 53,451441] [proc foo args {}] now
compiles to 0 bytecodes (sofer)
2001-09-13 (new feature)[TIP 56] Tcl_EvalTokensStandard API (sofer)
2001-09-13 (new feature) Old ChangeLog entries => ChangeLog.1999 (hobbs)
2001-09-17 (new feature) compiling with TCL_COMPILE_DEBUG now required to
enable all compile and execution tracing (sofer)
*** POTENTIAL INCOMPATIBILITY ***
2001-09-19 (bug fix)[411825] made TclNeedSpace UTF-8 aware (fellows)
2001-09-19 (bug fix)[219166] overagressive compilation of "quoted" bodies of
[for], [foreach], [if], and [while] (sofer)
|
| ︙ | ︙ | |||
5562 5563 5564 5565 5566 5567 5568 | 2002-07-28 (bug fix)[582522] alias fires exec traces (sofer) 2002-07-29 (bug fix)[578363] regexp (fellows,pvgoran) 2002-07-30 (bug fix)[584603] WriteChars infinite loop non-UTF-8 string (kupries) | | | | 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 |
2002-07-28 (bug fix)[582522] alias fires exec traces (sofer)
2002-07-29 (bug fix)[578363] regexp (fellows,pvgoran)
2002-07-30 (bug fix)[584603] WriteChars infinite loop non-UTF-8 string (kupries)
2002-08-04 (new feature)[584051,580433,585105,582429][TIP 27] Tcl interfaces
are now fully CONST-ified. Use the symbols USE_NON_CONST or
USE_COMPAT_CONST to select interfaces with fewer changes.
*** POTENTIAL INCOMPATIBILITY ***
2002-08-05 (bug fix)[589859] tcltest setup and cleanup scripts skipped when
test body is skipped (porter)
=> tcltest 2.2
2002-08-07 (bug fix)[587488] mem leak with USE_THREAD_ALLOC (sofer,sass)
2002-08-07 (feature enhancement)[584794,584650,472576] boolean values
are no longer always re-parsed from string. (sofer)
Many internal bugs fixed.
Considerable cleanup of the test suite.
--- Released 8.4b2, August 9, 2002 --- See ChangeLog for details ---
|
| ︙ | ︙ | |||
5706 5707 5708 5709 5710 5711 5712 |
=> tcltest 2.2.2
2003-02-01 (bug fix)[670042] corrected [info loaded {}] for static
packages in multiple interps.
2003-02-01 (bug fix)[675356] [clock clicks {}]; [clock clicks -] - syntax errs
| | | 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 |
=> tcltest 2.2.2
2003-02-01 (bug fix)[670042] corrected [info loaded {}] for static
packages in multiple interps.
2003-02-01 (bug fix)[675356] [clock clicks {}]; [clock clicks -] - syntax errs
2003-02-01 (bug fix)[656660] MT-safety for [clock format]
2003-02-03 (bug fix)[651271] command rename traces get fully-qualified names
*** POTENTIAL INCOMPATIBILITY ***
2003-02-07 (performance improvement) [glob] on Windows is 2.5 times faster
2003-02-07 (feature change) lack of Cygwin support indicated by config error
|
| ︙ | ︙ | |||
5925 5926 5927 5928 5929 5930 5931 | --- Released 8.4.5, November 20, 2003 --- See ChangeLog for details --- 2003-12-02 (bug fix)[851747] object sharing fix in [binary scan] 2003-12-09 (platform support)[852369] update errno usage for recent glibc | | | | 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 |
--- Released 8.4.5, November 20, 2003 --- See ChangeLog for details ---
2003-12-02 (bug fix)[851747] object sharing fix in [binary scan]
2003-12-09 (platform support)[852369] update errno usage for recent glibc
2003-12-12 (bug fix)[858937] fix for [file normalize ~nobody]
2003-12-17 (bug fix)[839519] fixed two memory leaks (vasiljevic)
2004-01-09 (bug fix)[873311] fixed infinite loop in TclFinalizeFilesystem
2004-02-02 (bug fix)[405995] Tcl_Ungets buffer filling fix
2004-02-04 (bug fix)[833910] tcltest command line option parsing error
=> tcltest 2.4.5
2004-02-04 (bug fix)[833637] code error in tcltest -preservecore operation
2004-02-12 (feature enhancement) update HP-11 build libs setup
2004-02-17 (bug fix)[849514,859251] corrected [file normailze] of $link/..
2004-02-17 (bug fix)[772288] Unix std channels forced to exist at startup.
2004-02-17 (new default) tcltest::configure -verbose {body error}
2004-02-19 (bug fix) init.tcl search path with unusual --libdir (samson)
|
| ︙ | ︙ | |||
6033 6034 6035 6036 6037 6038 6039 | operations, this will now be consumed by Tcl. * [TIP #138] New TCL_HASH_KEY_SYSTEM_HASH option for Tcl hash tables * [TIP #139] documented portions of Tcl's namespace C APIs * [TIP #148] correct [list]-quoting of the '#' character | | | 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 |
operations, this will now be consumed by Tcl.
* [TIP #138] New TCL_HASH_KEY_SYSTEM_HASH option for Tcl hash tables
* [TIP #139] documented portions of Tcl's namespace C APIs
* [TIP #148] correct [list]-quoting of the '#' character
*** POTENTIAL INCOMPATIBILITY ***
For scripts that assume a particular (buggy) string rep for lists.
* [TIP #156] add "root locale" to msgcat
=> msgcat 1.4
* [TIP #157] leading {expand} syntax on words to cause argument expansion.
This is a safer/cleaner alternative to the use of 'eval'.
|
| ︙ | ︙ | |||
6528 6529 6530 6531 6532 6533 6534 | 2005-07-15 (bug fix)[1237907] localtime() => NULL => crash (kenny) 2005-07-21 (dropped support) IRIX 4, RISCos, Ultrix, and ancient BSD (kenny) ***POTENTIAL INCOMPATIBILITY*** 2005-07-22 (enhancement)[1237755] 8.4 features in script library (fradin,porter) | | | 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 |
2005-07-15 (bug fix)[1237907] localtime() => NULL => crash (kenny)
2005-07-21 (dropped support) IRIX 4, RISCos, Ultrix, and ancient BSD (kenny)
***POTENTIAL INCOMPATIBILITY***
2005-07-22 (enhancement)[1237755] 8.4 features in script library (fradin,porter)
2005-07-24 (new feature) configure macros SC_PROG_TCLSH, SC_BUILD_TCLSH (dejong)
2005-07-26 (bug fix)[1047286] cmd delete traces during namespace delete (porter)
2005-07-26 (new unix feature)[1231015] ${prefix}/share on ::tcl_pkgPath (dejong)
***POTENTIAL INCOMPATIBILITY***
2005-07-27 (bug fix)[1214462] [unknown] can return exceptions (porter)
|
| ︙ | ︙ | |||
6623 6624 6625 6626 6627 6628 6629 | 2005-11-08 (bug fix)[1162286] [package require] checks that the script registered by [package ifneeded] provides the version it claims (lavana,porter) *** POTENTIAL INCOMPATIBILITY *** 2005-11-09 (bug fix)[1350293,1350291] [after $negative $script] fixed (kenny) | | | 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 | 2005-11-08 (bug fix)[1162286] [package require] checks that the script registered by [package ifneeded] provides the version it claims (lavana,porter) *** POTENTIAL INCOMPATIBILITY *** 2005-11-09 (bug fix)[1350293,1350291] [after $negative $script] fixed (kenny) 2005-11-12 (bug fix)[1352734,1354540,1355942,1355342] [namespace delete] issues with [namespace path] and command delete traces (sofer,fellows) 2005-11-18 (bug fix)[1358369] URL parsing standards compliance (wu,fellows) => http 2.5.2 2005-11-18 (revert) Restored registration of "list" Tcl_ObjType (porter) Reduces the ***POTENTIAL INCOMPATIBILITY*** from 2005-05-17. |
| ︙ | ︙ | |||
6752 6753 6754 6755 6756 6757 6758 | 2006-05-27 (bug fix)[923072] Darwin: made unthreaded CoreFoundation notifier naked-fork safe on Tiger (steffen) 2006-06-20 (internal change) Dropped the internal routines used to hook into filesystem operations back in the pre-Tcl_Filesystem days. (porter) ***POTENTIAL INCOMPATIBILITY*** | | | 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 | 2006-05-27 (bug fix)[923072] Darwin: made unthreaded CoreFoundation notifier naked-fork safe on Tiger (steffen) 2006-06-20 (internal change) Dropped the internal routines used to hook into filesystem operations back in the pre-Tcl_Filesystem days. (porter) ***POTENTIAL INCOMPATIBILITY*** For extensions and programs that have never migrated to the supported Tcl 8.4 interface for virtual filesystems 2006-07-05 (enhancement) Expression parser rewrite avoids stack overflow, reduces from O(N^2) to O(N) complexity, and greatly improves syntas error messages (porter) ***POTENTIAL INCOMPATIBILITY*** For any code relying on exact error messages. |
| ︙ | ︙ | |||
7599 7600 7601 7602 7603 7604 7605 | 2009-09-11 (enhancement)[2314561] [subst] now bytecompiled, NR-enabled (porter) 2009-09-24 (new feature)[TIP 356] Tcl_NRSubstObj() (porter) 2009-10-04 (bug fix)[2569449] Core Foundation memory bug in Tiger (steffen) | | | 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 | 2009-09-11 (enhancement)[2314561] [subst] now bytecompiled, NR-enabled (porter) 2009-09-24 (new feature)[TIP 356] Tcl_NRSubstObj() (porter) 2009-10-04 (bug fix)[2569449] Core Foundation memory bug in Tiger (steffen) 2009-10-06 (bug fix) repair intrep loss in slave interp evaluations introduced by first versions of the NRE conversion (nadkarni,porter) 2009-10-06 (bug fix)[1941434] broken tclTomMath.h includes (porter) 2009-10-07 (bug fix)[2871908] leaked hash table (mistachkin,kupries) 2009-10-08 (bug fix)[2874678] bignum leak in [dict incr] (fellows) |
| ︙ | ︙ | |||
7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 | 2011-08-30 (bug fix)[3398794] panic in interp limit setting (gavlian,fellows) 2011-09-08 (bug fix)[3401704] revised expr parser to permit function names like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter) *** POTENTIAL INCOMPATIBILITY *** 2011-09-13 (bug fix)[3390638] solaris studio cc workaround (kechel,porter) 2011-09-13 (bug fix)[3405652] DTrace workaround (michelson,porter) 2011-09-16 (bug fix)[3391977] -headers overrides -type (ziegenhagen,fellows) | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 |
2011-08-30 (bug fix)[3398794] panic in interp limit setting (gavlian,fellows)
2011-09-08 (bug fix)[3401704] revised expr parser to permit function names
like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter)
*** POTENTIAL INCOMPATIBILITY ***
2011-09-10 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows)
2011-09-13 (bug fix)[3390638] solaris studio cc workaround (kechel,porter)
2011-09-13 (bug fix)[3405652] DTrace workaround (michelson,porter)
2011-09-16 (bug fix)[3391977] -headers overrides -type (ziegenhagen,fellows)
=> http 2.8.3
2011-09-16 (TIP 388) New \Uhhhhhhhh syntax (nijtmans)
2011-10-06 (enhancement) bytecode compile [dict with] (fellows)
2011-10-11 (bug fix)[2935503] [file stat] returns bad mode (nadkarni,nijtmans)
2011-10-20 (bug fix)[3418547] cmd lits and custom resolvers (soberning,fellows)
2011-10-31 (bug fix)[3414754] EIAS violation in fs paths (porter)
2011-11-22 (bug fix)[3354324] Win: [file mtime] sets wrong time (nijtmans)
2011-11-30 (bug fix)[967195] Simply args passed to child processes (nijtmans)
=> tcltest 2.3.4
2011-12-07 (bug fix)[3444754] fix [string tolower \u01C5] (nijtmans)
2011-12-11 (update)[3457031] Update [[:print:]] to Unicode 6.0 (nijtmans)
2011-12-24 (bug fix)[3464428] fix [string is graph \u0120] (nijtmans)
2012-01-08 (bug fix)[3470928] zoneinfo trouble with Windhoek data file (kenny)
2012-01-13 (bug fix)[3472316] fix retrieval of socket error (fellows)
2012-01-21 (bug fix)[3475667] [regexp] buffer read overflow (sebres)
2012-01-22 (bug fix)[3475264] [dict exists] return 0, not error (fellows)
2012-01-25 (bug fix)[3474460] [oo::copy] var resolution list (fellows)
2012-01-26 (bug fix)[3475569,3479689] mem corrupt in fs path (sebres,porter)
2012-01-30 (enhancement) improve bytecode compile of [catch] (fellows)
2012-02-02 (bug fix)[2974459,2879351,1951574,1852572,1661378,1613456] Fix
problems where [file *able] would return false results on Win/Samba (porter)
2012-02-06 (bug fix)[3484621] bump bytecode epoch on exec traces (kuhn,sofer)
2012-02-15 (bug fix)[3487626] crash compiling [dict for] (fellows)
2012-02-15 (enhancement) bytecode compile [lrange],[lreplace] (fellows)
2012-02-17 (bug fix)[2233954] compile problem on AIX & Android (nijtmans)
2012-02-29 (bug fix)[3466099] BOM in Unicode (nijtmans)
2012-03-07 (bug fix)[3498327] RFC 3986 compliance (kupries)
2012-03-26 (TIP 380) New builtin class [oo::Slot] (fellows)
*** POTENTIAL INCOMPATIBILITY ***
2012-03-27 (TIP 397) <cloned> method to extend [oo::copy] (fellows)
*** POTENTIAL INCOMPATIBILITY ***
2012-03-27 (TIP 395) New subcommand [string is entier] (fellows)
2012-04-02 (TIP 396) New command [yieldto] (fellows)
2012-04-04 (bug fix)[3514761] crash combining objects and ensembles (fellows)
2012-04-09 (bug fix)[2712377] [info vars] and oo variables (fellows)
2012-04-09 (bug fix)[3396896] no dups in oo var lists (fellows)
2012-04-11 (bug fix)[3448512] [clock scan 1958-01-01] fail on Win (nijtmans)
2012-04-15 (bug fix)[3517696] fix flush of zlib chan xform (fellows)
2012-04-18 tzdata updated to Olson's tzdata2012c (kenny)
2012-04-28 (TIP 398) exit non-blocking chan without flush (ferrieux)
*** POTENTIAL INCOMPATIBILITY ***
2012-05-02 (enhancement) Better use of Intel cpuid instruction (nijtmans)
2012-05-03 (bug fix)[3428753] Unbreak synchronous [socket -async] (porter)
2012-05-10 (bug fix)[2812981] force consistent config of Tcl+pkgs (ferrieux)
2012-05-10 (bug fix)[473946] correct send of special characters (nijtmans)
2012-05-17 (bug fix)[3445787] fix [file] ensemble in Safe Base (fellows)
2012-05-17 (bug fix)[2964715] fix [glob] in Safe Base (fellows)
2012-05-17 (bug fix)[3106532] proper [switch -indexvar] values (fellows)
*** POTENTIAL INCOMPATIBILITY ***
2012-05-21 (TIP 106) New -binary option to [dde execute|poke] (oehlmann)
=> dde 1.4.0
2012-05-23 (bug fix)[3525907] [zlib push decompress] & [chan event]
(fellows,ferrieux,kupries)
2012-05-28 (bug fix)[3529949] Protect ~ paths in Safe Base (fellows)
2012-06-21 (bug fix)[3362446] [registry keys] failure (nijtmans)
=> registry 1.3.0
2012-06-25 (bug fix)[3537605] [encoding dirs a b] error message (fellows)
2012-06-25 (bug fix)[3024359] crash when multi-thread concurrent [file system]
and Tcl_FSMountsChanged(). (porter)
2012-06-29 (bug fix)[3536888] fix locale guessing (oehlmann,nijtmans)
2012-07-05 (bug fix)[1189293] make "<<" redirect binary safe (porter)
2012-07-08 (bug fix)[3531209] accept IPv6 URLs (max)
=> http 2.8.4
2012-07-24 (bug fix) stop mem corruption in stacked channel events (max,porter)
2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert)
2012-07-27 (update)[3464401] Support Unicode 6.2 (nijtmans)
2012-08-20 (bug fix)[3559678] [file normalize] EIAS failure (phao,dgp)
2012-08-25 (bug fix)[3561330] Ukranian translation of "March" (teterin)
2012-09-07 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann)
=> msgcat 1.5.0
Many revisions to better support a Cygwin environment (nijtmans)
Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
--- Released 8.6b3, September 18, 2012 --- See ChangeLog for details ---
2012-09-20 (enhancement) full Unicode support (nijtmans)
=> dde 1.4.0
2012-09-20 (enhancement) update bundled zlib to 1.2.7 (nijtmans)
2012-10-03 (bug fix) exit panic on stacked std channel (griffin,porter)
2012-10-14 (bug fix) [tcl::Bgerror] crash on non-dict options (nijtmans)
2012-10-16 (TIP 400) New [zlib] options to set compression dict (fellows)
2012-10-16 (TIP 405) New commands [lmap] and [dict map] (fellows)
2012-10-24 (enhancement) [dict unset] now bytecompiled (fellows)
2012-11-05 (TIP 413) Revisions to default [string trim*] trimset (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
2012-11-05 (enhancement) Now bytecompiled: [array exists], [array set],
[array unset], [dict create], [dict exists], [dict merge], [format],
[info commands], [info coroutine], [info level], [info object],
[namespace current], [namespace code], [namespace qualifiers], [namespace tail],
[namespace which], [regsub], [self], [string first], [string last],
[string map], [string range], [tailcall], [yield]. (fellows)
2012-11-06 (bug fix)[3581754] avoid multiple callback on keep-alive (fellows)
=> http 2.8.5
2012-11-07 tzdata updated to Olson's tzdata2012i (kenny)
2012-11-13 (bug fix)[3567063] thread fp settings from master (mistachkin)
2012-11-14 (bug fix)[2933003] tempfile creation in $TMPDIR (fellows)
2012-11-15 (TIP 416) New [load] options -global and -lazy (nijtmans)
2012-11-20 (bug fix)[3033307] base64 trail whitespace (kovalenko,goth)
2012-12-03 (bug fix) [configure] query broke init from argv (porter)
=> tcltest 2.3.5
2012-12-13 (bug fix)[3595576] crash: [catch {} -> noSuchNs::var] (sofer,porter)
2012-12-13 (bug fix) crash: [zlib gunzip $data -header noSuchNs::var] (porter)
--- Released 8.6.0, December 20, 2012 --- See ChangeLog for details ---
|
Changes to compat/dirent2.h.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _DIRENT #define _DIRENT | < < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _DIRENT #define _DIRENT /* * Dirent structure, which holds information about a single * directory entry. */ #define MAXNAMLEN 255 #define DIRBLKSIZ 512 |
| ︙ | ︙ |
Changes to compat/dlfcn.h.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH * 30159 Hannover, Germany */ #ifndef __dlfcn_h__ #define __dlfcn_h__ | < < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
* This is an unpublished work copyright (c) 1992 HELIOS Software GmbH
* 30159 Hannover, Germany
*/
#ifndef __dlfcn_h__
#define __dlfcn_h__
#ifdef __cplusplus
extern "C" {
#endif
/*
* Mode flags for the dlopen routine.
*/
|
| ︙ | ︙ |
Changes to compat/string.h.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _STRING #define _STRING | < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _STRING #define _STRING /* * The following #include is needed to define size_t. (This used to include * sys/stdtypes.h but that doesn't exist on older versions of SunOS, e.g. * 4.0.2, so I'm trying sys/types.h now.... hopefully it exists everywhere) */ #include <sys/types.h> |
| ︙ | ︙ |
Changes to compat/unistd.h.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * 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 | < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * 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 /* |
| ︙ | ︙ |
Changes to compat/zlib/win32/zdll.lib.
cannot compute difference between binary files
Added compat/zlib/win64/zdll.lib.
cannot compute difference between binary files
Added compat/zlib/win64/zlib1.dll.
cannot compute difference between binary files
Changes to doc/AddErrInfo.3.
| ︙ | ︙ | |||
103 104 105 106 107 108 109 | \fB\-errorcode\fR, and \fB\-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB\-code\fR and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | \fB\-errorcode\fR, and \fB\-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB\-code\fR and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting any entries in it, without the need to check for a shared value. As with any \fBTcl_Obj\fR with reference count of zero, it is up to the caller to arrange for its disposal with \fBTcl_DecrRefCount\fR or to a reference to it via \fBTcl_IncrRefCount\fR (or one of the many functions that call that, notably including \fBTcl_SetObjResult\fR and \fBTcl_SetVar2Ex\fR). .PP A typical usage for \fBTcl_GetReturnOptions\fR is to |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the | | | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the \fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR built up by the caller. \fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .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. .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full |
| ︙ | ︙ | |||
305 306 307 308 309 310 311 | \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), tclvars(n) .SH KEYWORDS | | | 305 306 307 308 309 310 311 312 | \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), tclvars(n) .SH KEYWORDS error, value, value result, stack, trace, variable |
Changes to doc/BoolObj.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP int *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS | | | 88 89 90 91 92 93 94 95 | while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS boolean, value |
Changes to doc/ByteArrObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 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. '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | '\" '\" Copyright (c) 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. '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) .sp void \fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) .sp unsigned char * \fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. .AP int length in The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array value, it will be converted to one. .AP int *lengthPtr out If non-NULL, filled with the length of the array of bytes in the value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl byte-array values from C code. Byte-array values are typically used to hold the results of binary IO operations or data structures created with the \fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a string. Conceptually, a string is an array of Unicode characters, while a byte-array is an array of 8-bit quantities with no implicit meaning. Accessor functions are provided to get the string representation of a byte-array or to convert an arbitrary value to a byte-array. Obtaining the string representation of a byte-array value (by calling \fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the UTF-8 characters in the string representation. .PP \fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will create a new value of byte-array type or modify an existing value to have a byte-array type. Both of these procedures set the value's type to be byte-array and set the value's internal representation to a copy of the array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a pointer to a newly allocated value with a reference count of zero. \fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if the value is not already a byte-array value, frees any old internal representation. If \fIbytes\fR is NULL then the new byte array contains arbitrary values. .PP \fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and returns a pointer to the value's new internal representation as an array of bytes. The length of this array is stored in \fIlengthPtr\fR if \fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by the value and should not be freed. The contents of the array may be modified by the caller only if the value is not shared and the caller invalidates the string representation. .PP \fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type and changes the length of the value's internal representation as an array of bytes. If \fIlength\fR is greater than the space currently allocated for the array, the array is reallocated to the new length; the newly allocated bytes at the end of the array have arbitrary values. If \fIlength\fR is less than the space currently allocated for the array, the length of array is reduced to the new length. The return value is a pointer to the value's new array of bytes. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS value, binary data, byte array, utf, unicode, internationalization |
Changes to doc/CrtChannel.3.
| ︙ | ︙ | |||
246 247 248 249 250 251 252 | \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or | | | | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or output. The \fIsize\fR argument should be between one and one million, allowing buffers of one byte to one million bytes. If \fIsize\fR is outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have occurred on the channel. Channel drivers are responsible for invoking this function whenever the channel handlers need to be called for the |
| ︙ | ︙ | |||
842 843 844 845 846 847 848 | (optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP It always returns \fBTCL_ERROR\fR .PP | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
(optional) interpreter. It is used by channel drivers when
an invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
the generic options error message string.
.PP
It always returns \fBTCL_ERROR\fR
.PP
An error message is generated in \fIinterp\fR's result value to
indicate that a command was invoked with a bad option.
The message has the form
.CS
bad option "blah": should be one of
<...generic options...>+<...specific options...>
.CE
so you get for instance:
|
| ︙ | ︙ |
Changes to doc/CrtCommand.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of | | | | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of argument strings instead of values. The value-based command procedures registered by \fBTcl_CreateObjCommand\fR can execute significantly faster than the string-based command procedures defined by \fBTcl_CreateCommand\fR. This is because they take Tcl values as arguments and those values can retain an internal representation that can be manipulated more efficiently. Also, Tcl's interpreter now uses values internally. In order to invoke a string-based command procedure registered by \fBTcl_CreateCommand\fR, it must generate and fetch a string representation from each argument value before the call. New commands should be defined using \fBTcl_CreateObjCommand\fR. We support \fBTcl_CreateCommand\fR for backwards compatibility. .PP The procedures \fBTcl_DeleteCommand\fR, \fBTcl_GetCommandInfo\fR, and \fBTcl_SetCommandInfo\fR are used in conjunction with \fBTcl_CreateCommand\fR. .PP |
| ︙ | ︙ |
Changes to doc/CrtMathFnc.3.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH "NOTICE OF EVENTUAL DEPRECATION" .PP The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions are rendered somewhat obsolete by the ability to create functions for expressions by placing commands in the \fBtcl::mathfunc\fR namespace, as described in the \fBmathfunc\fR manual page; the API described on this page is not expected to be maintained indefinitely. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp |
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP \fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all the math functions defined in the interpreter whose name matches \fIpattern\fR. The returned value has a reference count of zero. .SH "SEE ALSO" expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) .SH KEYWORDS expression, mathematical function |
Changes to doc/CrtObjCmd.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in Value containing the name of a Tcl command. .BE .SH DESCRIPTION .PP \fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIname\fR is invoked as a Tcl command (e.g., via a call to \fBTcl_EvalObjEx\fR) |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | .CE .PP When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the | | | | | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | .CE .PP When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the arguments to the command, \fIobjc\fR giving the number of argument values (including the command name) and \fIobjv\fR giving the values of the arguments. The \fIobjv\fR array will contain \fIobjc\fR values, pointing to the argument values. Unlike \fIargv\fR[\fIargv\fR] used in a string-based command procedure, \fIobjv\fR[\fIobjc\fR] will not contain NULL. .PP Additionally, when \fIproc\fR is invoked, it must not modify the contents of the \fIobjv\fR array by assigning new pointer values to any element of the array (for example, \fIobjv\fR[\fB2\fR] = \fBNULL\fR) because this will cause memory to be lost and the runtime stack to be corrupted. The \fBconst\fR in the declaration of \fIobjv\fR will cause ANSI-compliant compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual value argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, if \fIproc\fR needs to return a non-empty result, it can call \fBTcl_SetObjResult\fR to set the interpreter's result. In the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR this gives an error message. Before invoking a command procedure, \fBTcl_EvalObjEx\fR sets interpreter's result to point to a value representing an empty string, so simple commands can return an empty result by doing nothing at all. .PP The contents of the \fIobjv\fR array belong to Tcl and are not guaranteed to persist once \fIproc\fR returns: \fIproc\fR should not modify them. Call \fBTcl_SetObjResult\fR if you want to return something from the \fIobjv\fR array. |
| ︙ | ︙ | |||
221 222 223 224 225 226 227 | It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; | | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 | It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; they hold information about the value-based command procedure that the Tcl interpreter calls to implement the command. The fields \fIproc\fR and \fIclientData\fR hold information about the string-based command procedure that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. The field \fIdeleteData\fR is the ClientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. The field \fInamespacePtr\fR holds a pointer to the Tcl_Namespace that contains the command. .PP |
| ︙ | ︙ | |||
286 287 288 289 290 291 292 | owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name of a command from a command token. The name, including all namespace prefixes, | | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name of a command from a command token. The name, including all namespace prefixes, is appended to the value specified by \fIobjPtr\fR. .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS bind, command, create, delete, namespace, value |
Changes to doc/CrtSlave.3.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in | | | | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in Count of additional value arguments to pass to the aliased command. .AP Tcl_Obj **objv in Vector of Tcl_Obj structures, the additional value arguments to pass to the aliased command. This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target command is defined for an alias. .AP "const char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. .AP int *argcPtr out Pointer to location to store count of additional arguments to be passed to the alias. The location is in storage owned by the caller. .AP "const char" ***argvPtr out Pointer to location to store a vector of strings, the additional arguments to pass to an alias. The location is in storage owned by the caller, the vector of strings is owned by the called function. .AP int *objcPtr out Pointer to location to store count of additional value arguments to be passed to the alias. The location is in storage owned by the caller. .AP Tcl_Obj ***objvPtr out Pointer to location to store a vector of Tcl_Obj structures, the additional arguments to pass to an alias command. The location is in storage owned by the caller, the vector of Tcl_Obj structures is owned by the called function. .AP "const char" *cmdName in Name of an exposed command to hide or create. .AP "const char" *hiddenCmdName in Name under which a hidden command is stored and with which it can be exposed or invoked. |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | \fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and the \fIresult\fR field in \fIaskingInterp\fR contains the error message. .PP | | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | \fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and the \fIresult\fR field in \fIaskingInterp\fR contains the error message. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if it fails; in that case, an error message is left in the value result of \fIslaveInterp\fR. Note that there are no restrictions on the ancestry relationship (as created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP \fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP \fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in which case the corresponding datum is not returned. If a result field is non\-\fBNULL\fR, the address indicated is set to the corresponding datum. For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 | it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the \fIresult\fR field in \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message in the | | | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the \fIresult\fR field in \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message in the value result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. After executing this command, attempts to use \fIcmdName\fR in a call to \fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed. .PP \fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of exposed commands to the set of hidden commands, under the name \fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the value result of \fIinterp\fR. Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and leave an error message in the value result of \fIinterp\fR. The \fICmdName\fR will be looked up in the global namespace, and not relative to the current namespace, even if the current namespace is not the global one. If a hidden command whose name is \fIhiddenCmdName\fR already exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR field in \fIinterp\fR contains an error message. If the operation succeeds, it returns \fBTCL_OK\fR. |
| ︙ | ︙ |
Changes to doc/DictObj.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" 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_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" 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_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl values as dictionaries .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewDictObj\fR() .sp |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in | | | | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | \fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in If an error occurs while converting a value to be a dictionary value, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP Tcl_Obj *dictPtr in/out Points to the dictionary value to be manipulated. If \fIdictPtr\fR does not already point to a dictionary value, an attempt will be made to convert it to one. .AP Tcl_Obj *keyPtr in Points to the key for the key/value pair being manipulated within the dictionary value. .AP Tcl_Obj **keyPtrPtr out Points to a variable that will have the key from a key/value pair placed within it. May be NULL to indicate that the caller is not interested in the key. .AP Tcl_Obj *valuePtr in Points to the value for the key/value pair being manipulated within the dictionary value (or sub-value, in the case of \fBTcl_DictObjPutKeyList\fR.) .AP Tcl_Obj **valuePtrPtr out Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. .AP int *sizePtr out |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in | | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in Array of \fIkeyc\fR pointers to values that \fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will use to locate the key/value pair to manipulate within the sub-dictionaries of the main dictionary value passed to them. .BE .SH DESCRIPTION .PP Tcl dictionary values have an internal representation that supports efficient mapping from keys to values and which guarantees that the particular ordering of keys within the dictionary remains the same modulo any keys being deleted (which removes them from the order) or added (which adds them to the end of the order). If reinterpreted as a list, the values at the even-valued indices in the list will be the keys of the dictionary, and each will be followed (in the odd-valued index) by the value associated with that key. .PP The procedures described in this man page are used to create, modify, index, and iterate over dictionary values from C code. .PP \fBTcl_NewDictObj\fR creates a new, empty dictionary value. The string representation of the value will be invalid, and the reference count of the value will be zero. .PP \fBTcl_DictObjGet\fR looks up the given key within the given dictionary and writes a pointer to the value associated with that key into the variable pointed to by \fIvaluePtrPtr\fR, or a NULL if the key has no mapping within the dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be converted to a dictionary. |
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search,
&key, &value, &done) != TCL_OK) {
return TCL_ERROR;
}
for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) {
/*
* Note that strcmp() is not a good way of comparing
| | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search,
&key, &value, &done) != TCL_OK) {
return TCL_ERROR;
}
for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) {
/*
* Note that strcmp() is not a good way of comparing
* values and is just used here for demonstration
* purposes.
*/
if (!strcmp(Tcl_GetString(key), Tcl_GetString(value))) {
break;
}
}
\fBTcl_DictObjDone\fR(&search);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!done));
return TCL_OK;
.CE
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_InitObjHashTable
.SH KEYWORDS
dict, dict value, dictionary, dictionary value, hash table, iteration, value
|
Changes to doc/DoubleObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl values as floating-point values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewDoubleObj\fR(\fIdoubleValue\fR) .sp \fBTcl_SetDoubleObj\fR(\fIobjPtr, doubleValue\fR) .sp int \fBTcl_GetDoubleFromObj\fR(\fIinterp, objPtr, doublePtr\fR) .SH ARGUMENTS .AS Tcl_Interp doubleValue in/out .AP double doubleValue in A double-precision floating-point value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetDoubleObj\fR, this points to the value in which to store a double value. For \fBTcl_GetDoubleFromObj\fR, this refers to the value from which to retrieve a double value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when double value retrieval fails. .AP double *doublePtr out Points to place to store the double value obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl values that hold double-precision floating-point values. .PP \fBTcl_NewDoubleObj\fR creates and returns a new Tcl value initialized to the double value \fIdoubleValue\fR. The returned Tcl value is unshared. .PP \fBTcl_SetDoubleObj\fR sets the value of an existing Tcl value pointed to by \fIobjPtr\fR to the double value \fIdoubleValue\fR. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value 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 \fBTcl_GetDoubleFromObj\fR attempts to retrieve a double value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the double value is written to the storage pointed to by \fIdoublePtr\fR. 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 \fBTcl_GetDoubleFromObj\fR more efficient. '\" TODO: add discussion of treatment of NaN value .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS double, double value, double type, internal representation, value, value type, string representation |
Changes to doc/Eval.3.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. .AP int objc in The number of values in the array pointed to by \fIobjPtr\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in Points to an array of pointers to values; each value holds the value of a single word in the command to execute. .AP int numBytes in The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step can be skipped if the value is evaluated again in the future. .PP The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values | | | | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each value in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the elements of \fIobjv\fR, insuring that the values are valid until \fBTcl_EvalObjv\fR returns. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to be executed is supplied as a string instead of a value and no compilation occurs. The string should be a proper UTF-8 string as converted by \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known to possibly contain upper ASCII characters whose possible combinations might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to \fIinterp->result\fR (use is deprecated) where it can be accessed directly. This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which does not do the copy. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes additional arguments \fInumBytes\fR and \fIflags\fR. For the efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the contents of a value are going to change immediately, so the bytecodes will not be reused in a future execution. In this case, it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . If this flag is set, the script is processed at global level. This means that it is evaluated in the global namespace and its variable |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS | | | 204 205 206 207 208 209 210 211 | and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS execute, file, global, result, script, value |
Changes to doc/ExprLong.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the value-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR. Those value-based procedures evaluate an expression held in a Tcl value instead of a string. The value argument can retain an internal representation that is more efficient to execute. .PP The \fIinterp\fR argument refers to an interpreter used to evaluate the expression (e.g. for variables and nested Tcl commands) and to return error information. .PP For all of these procedures the return value is a standard |
| ︙ | ︙ | |||
99 100 101 102 103 104 105 | \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS | | | 99 100 101 102 103 104 105 106 | \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS boolean, double, evaluate, expression, integer, value, string |
Changes to doc/ExprLongObj.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in | | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in Pointer to a value containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the expression. .AP int *booleanPtr out Pointer to location in which to store the 0/1 boolean value of the expression. .AP Tcl_Obj **resultPtrPtr out Pointer to location in which to store a pointer to the value that is the result of the expression. .BE .SH DESCRIPTION .PP These four procedures all evaluate an expression, returning the result in one of four different forms. |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | such as .QW yes or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, | | | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | such as .QW yes or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, it stores a pointer to the Tcl value containing the expression's value at \fI*resultPtrPtr\fR. In this case, the caller is responsible for calling \fBTcl_DecrRefCount\fR to decrement the value's reference count when it is finished with the value. .SH "SEE ALSO" Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult .SH KEYWORDS boolean, double, evaluate, expression, integer, value, string |
Changes to doc/FileSystem.3.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | .sp int \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | .sp int \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp const char *const * \fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR) .sp int \fBTcl_FSStat\fR(\fIpathPtr, statPtr\fR) .sp int \fBTcl_FSAccess\fR(\fIpathPtr, mode\fR) |
| ︙ | ︙ | |||
188 189 190 191 192 193 194 | .VE 8.6 .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in | | | | | | | | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | .VE 8.6 .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in The path represented by this value is used for the operation in question. If the value does not already have an internal \fBpath\fR representation, it will be converted to have one. .AP Tcl_Obj *srcPathPtr in As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. .AP Tcl_Obj *destPathPtr in As for \fIpathPtr\fR, but used for the destination filename for a copy or rename operation. .AP "const char" *encodingName in The encoding of the data stored in the file identified by \fIpathPtr\fR and to be evaluated. .AP "const char" *pattern in Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. .AP ClientData clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. .AP int elements in If non-negative, the number of elements in the \fIlistObj\fR which should be joined together. If negative, then all elements are joined. .AP Tcl_Obj **errorPtr out In the case of an error, filled with a value containing the name of the file which caused an error in the various copy/rename operations. .AP Tcl_Obj **objPtrRef out Filled with a value containing the result of the operation. .AP Tcl_Obj *resultPtr out Pre-allocated value in which to store (using \fBTcl_ListObjAppendElement\fR) the list of files or directories which are successfully matched. .AP int mode in Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK, W_OK and X_OK request checking whether the file exists and has read, write and execute permissions, respectively. F_OK just requests checking for the existence of the file. |
| ︙ | ︙ | |||
327 328 329 330 331 332 333 | listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP | | | | | | | | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP The \fBTcl_FS\fR API is \fBTcl_Obj\fR-ified and may cache internal representations and other path-related strings (e.g.\ the current working directory). One side-effect of this is that one must not pass in values with a reference count of zero to any of these functions. If such calls were handled, they might result in memory leaks (under some circumstances, the filesystem code may wish to retain a reference to the passed in value, and so one must not assume that after any of these calls return, the value still has a reference count of zero - it may have been incremented) or in a direct segmentation fault (or other memory access error) due to the value being freed part way through the complex value manipulation required to ensure that the path is fully normalized and absolute for filesystem determination. The practical lesson to learn from this is that .PP .CS Tcl_Obj *path = Tcl_NewStringObj(...); Tcl_FS\fIWhatever\fR(path); Tcl_DecrRefCount(path); .CE .PP is wrong, and may cause memory errors. The \fIpath\fR must have its reference count incremented before passing it in, or decrementing it. For this reason, values with a reference count of zero are considered not to be valid filesystem paths and calling any Tcl_FS API function with such a value will result in no action being taken. .SS "FS API FUNCTIONS" \fBTcl_FSCopyFile\fR attempts to copy the file given by \fIsrcPathPtr\fR to the path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's .QW "copy file" function is called (if it is non-NULL). |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link of one of the types passed in in the \fIlinkAction\fR flag. This flag is an ORed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. Where a choice exists (i.e.\ more than one flag is passed in), the Tcl convention is to prefer symbolic links. When a link is successfully created, the return value should be \fItoPtr\fR (which is therefore already owned by the caller). If unsuccessful, NULL is returned. |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 | .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP If the result is \fBTCL_OK\fR, then a value was placed in \fIobjPtrRef\fR, which will only be temporarily valid (unless \fBTcl_IncrRefCount\fR is called). .PP \fBTcl_FSFileAttrsSet\fR implements write access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP \fBTcl_FSFileAttrStrings\fR implements part of the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The called procedure may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it retains a reference count to the value. .PP \fBTcl_FSAccess\fR checks whether the process would be allowed to read, write or test for existence of the file (or other filesystem object) whose name is \fIpathname\fR. If \fIpathname\fR is a symbolic link on Unix, then permissions of the file referred by this symbolic link are tested. .PP |
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length 1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path | | | | | | | | | | | | | | | | | > | | | | | | | | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length 1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path value given by considering the first \fIelements\fR elements as valid path segments (each path segment may be a complete path, a partial path or just a single possible directory or file name). If any path segment is actually an absolute path, then all prior path segments are discarded. If \fIelements\fR is less than 0, we use the entire list. .PP It is possible that the returned value is actually an element of the given list, so the caller should be careful to increment the reference count of the result before freeing the list. .PP The returned value, typically with a reference count of zero (but it could be shared under some conditions), contains the joined path. The caller must add a reference count to the value before using it. In particular, the returned value could be an element of the given list, so freeing the list might free the value prematurely if no reference count has been taken. If the number of elements is zero, then the returned value will be an empty-string Tcl_Obj. .PP \fBTcl_FSSplitPath\fR takes the given Tcl_Obj, which should be a valid path, and returns a Tcl list value containing each segment of that path as an element. It returns a list value with a reference count of zero. If the passed in \fIlenPtr\fR is non-NULL, the variable it points to will be updated to contain the number of elements in the returned list. .PP \fBTcl_FSEqualPaths\fR tests whether the two paths given represent the same filesystem object. It returns 1 if the paths are equal, and 0 if they are different. If either path is NULL, 0 is always returned. .PP \fBTcl_FSGetNormalizedPath\fR this important function attempts to extract from the given Tcl_Obj a unique normalized path representation, whose string value can be used as a unique identifier for the file. .PP It returns the normalized path value, owned by Tcl, or NULL if the path was invalid or could otherwise not be successfully converted. Extraction of absolute, normalized paths is very efficient (because the filesystem operates on these representations internally), although the result when the filesystem contains numerous symbolic links may not be the most user-friendly version of a path. The return value is owned by Tcl and has a lifetime equivalent to that of the \fIpathPtr\fR passed in (unless that is a relative path, in which case the normalized path value may be freed any time the cwd changes) - the caller can of course increment the reference count if it wishes to maintain a copy for longer. .PP \fBTcl_FSJoinToPath\fR takes the given value, which should usually be a valid path or NULL, and joins onto it the array of paths segments given. .PP Returns a value, typically with reference count of zero (but it could be shared under some conditions), containing the joined path. The caller must add a reference count to the value before using it. If any of the values passed into this function (\fIpathPtr\fR or \fIpath\fR elements) have a reference count of zero, they will be freed when this function returns. .PP \fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid Tcl path type, taking account of the fact that the cwd may have changed even if this value is already supposedly of the correct type. The filename may begin with .QW ~ (to indicate current user's home directory) or .QW ~<user> (to indicate any user's home directory). .PP If the conversion succeeds (i.e.\ the value is a valid path in one of the current filesystems), then \fBTCL_OK\fR is returned. Otherwise \fBTCL_ERROR\fR is returned, and an error message may be left in the interpreter. .PP \fBTcl_FSGetInternalRep\fR extracts the internal representation of a given path value, in the given filesystem. If the path value belongs to a different filesystem, we return NULL. If the internal representation is currently NULL, we attempt to generate it, by calling the filesystem's \fBTcl_FSCreateInternalRepProc\fR. .PP Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP \fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path from the given Tcl_Obj. .PP If the translation succeeds (i.e.\ the value is a valid path), then it is returned. Otherwise NULL will be returned, and an error message may be left in the interpreter. A .QW translated path is one which contains no .QW ~ or .QW ~user sequences (these have been expanded to their current representation in the filesystem). The value returned is owned by the caller, which must store it or call \fBTcl_DecrRefCount\fR to ensure memory is freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g.\ \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an efficient way of creating the appropriate path value type. .PP The resulting value is a pure .QW path value, which will only receive a UTF-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix native filesystems, so that they can easily retrieve the native (char* or TCHAR*) representation of a path. This function is a convenience wrapper around \fBTcl_FSGetInternalRep\fR. It may be desirable in the future to have non-string-based native representations (for example, |
| ︙ | ︙ | |||
769 770 771 772 773 774 775 | or .QW prowrap , perhaps), and the second is the particular type of the given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP | | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 | or .QW prowrap , perhaps), and the second is the particular type of the given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP A valid list value is returned, unless the path value is not recognized, when NULL will be returned. .PP \fBTcl_FSGetFileSystemForPath\fR returns a pointer to the \fBTcl_Filesystem\fR which accepts this path as valid. .PP If no filesystem will accept the path, NULL is returned. .PP |
| ︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 | changes in a future Tcl release. .SS VERSION .PP The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR. .SS PATHINFILESYSTEMPROC .PP The \fIpathInFilesystemProc\fR field contains the address of a function | | | | | | | | | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
changes in a future Tcl release.
.SS VERSION
.PP
The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR.
.SS PATHINFILESYSTEMPROC
.PP
The \fIpathInFilesystemProc\fR field contains the address of a function
which is called to determine whether a given path value belongs to this
filesystem or not. Tcl will only call the rest of the filesystem
functions with a path for which this function has returned \fBTCL_OK\fR.
If the path does not belong, -1 should be returned (the behavior of Tcl
for any other return value is not defined). If \fBTCL_OK\fR is returned,
then the optional \fIclientDataPtr\fR output parameter can be used to
return an internal (filesystem specific) representation of the path,
which will be cached inside the path value, and may be retrieved
efficiently by the other filesystem functions. Tcl will simultaneously
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
ClientData *\fIclientDataPtr\fR);
.CE
.SS DUPINTERNALREPPROC
.PP
This function makes a copy of a path's internal representation, and is
called when Tcl needs to duplicate a path value. If NULL, Tcl will
simply not copy the internal representation, which may then need to be
regenerated later.
.PP
.CS
typedef ClientData \fBTcl_FSDupInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS FREEINTERNALREPPROC
Free the internal representation. This must be implemented if internal
representations need freeing (i.e.\ if some memory is allocated when an
internal representation is generated), but may otherwise be NULL.
.PP
.CS
typedef void \fBTcl_FSFreeInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS INTERNALTONORMALIZEDPROC
.PP
Function to convert internal representation to a normalized path. Only
required if the filesystem creates pure path values with no string/path
representation. The return value is a Tcl value whose string
representation is the normalized path.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR(
ClientData \fIclientData\fR);
.CE
.SS CREATEINTERNALREPPROC
.PP
Function to take a path value, and calculate an internal
representation for it, and store that native representation in the
value. May be NULL if paths have no internal representation, or if
the \fITcl_FSPathInFilesystemProc\fR for this filesystem always
immediately creates an internal representation for paths it accepts.
.PP
.CS
typedef ClientData \fBTcl_FSCreateInternalRepProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS NORMALIZEPATHPROC
.PP
Function to normalize a path. Should be implemented for all
filesystems which can have multiple string representations for the same
path value. In Tcl, every
.QW path
must have a single unique
.QW normalized
string representation. Depending on the filesystem,
there may be more than one unnormalized string representation which
refers to that path (e.g.\ a relative path, a path with different
character case if the filesystem is case insensitive, a path contain a
reference to a home directory such as
.QW ~ ,
a path containing symbolic
links, etc). If the very last component in the path is a symbolic
link, it should not be converted into the value it points to (but
its case or other aspects should be made unique). All other path
components should be converted from symbolic links. This one
exception is required to agree with Tcl's semantics with \fBfile
delete\fR, \fBfile rename\fR, \fBfile copy\fR operating on symbolic links.
This function may be called with \fInextCheckpoint\fR either
at the beginning of the path (i.e.\ zero), at the end of the path, or
at any intermediate file separator in the path. It will never
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 | and should be returned as the string representation of the Tcl_Obj which is returned. A typical return value might be .QW networked , .QW zip or .QW ftp . The Tcl_Obj result is owned by the filesystem and so Tcl will | | | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
and should be returned as the string representation of the Tcl_Obj
which is returned. A typical return value might be
.QW networked ,
.QW zip
or
.QW ftp .
The Tcl_Obj result is owned by the filesystem and so Tcl will
increment the reference count of that value if it wishes to retain a reference
to it.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSFilesystemPathTypeProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS FILESYSTEMSEPARATORPROC
.PP
Function to return the separator character(s) for this filesystem.
This need only be implemented if the filesystem wishes to use a
different separator than the standard string
.QW / .
Amongst other
uses, it is returned by the \fBfile separator\fR command. The
return value should be a value with reference count of zero.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSFilesystemSeparatorProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS STATPROC
.PP
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 | documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be | | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 | documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be added to the \fIresultPtr\fR value given (which can be assumed to be a valid unshared Tcl list). The matches added to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR (this usually means they will be absolute path specifications). Note that if no matches are found, that simply leads to an empty result; errors are only signaled for actual file or filesystem problems which may occur during the matching process. .PP |
| ︙ | ︙ | |||
1322 1323 1324 1325 1326 1327 1328 | .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller (and should therefore have its ref count incremented before being returned). Any callers | | | | | | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 | .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller (and should therefore have its ref count incremented before being returned). Any callers should call \fBTcl_DecrRefCount\fR on this result when it is no longer needed. If \fItoPtr\fR is not NULL, the function should attempt to create a link. The result in this case should be \fItoPtr\fR if the link was successful and NULL otherwise. In this case the result is not owned by the caller (i.e.\ no reference count manipulations on either end are needed). See the documentation for \fBTcl_FSLink\fR for the correct interpretation of the \fIlinkAction\fR flags. .SS LISTVOLUMESPROC .PP 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, so that they can be returned by \fBfile volumes\fR. .PP .CS typedef Tcl_Obj *\fBTcl_FSListVolumesProc\fR(void); .CE .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a .QW "master list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then they simply increment the reference count of their master list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC .PP Function to list all attribute strings which are valid for this |
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it returns a value with a reference count of at least one. .SS FILEATTRSGETPROC .PP Function to process a \fBTcl_FSFileAttrsGet\fR call, used by \fBfile attributes\fR. .PP .CS |
| ︙ | ︙ |
Changes to doc/GetIndex.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
msg, flags, indexPtr\fR)
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
| | > > > > > > | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
msg, flags, indexPtr\fR)
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this value is used to search through \fItablePtr\fR.
The internal representation is modified to hold the index of the matching
table entry.
.AP "const char *const" *tablePtr in
An array of null-terminated strings. The end of the array is marked
by a NULL string pointer.
Note that references to the \fItablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array.
.AP "const void" *structTablePtr in
An array of arbitrary type, typically some \fBstruct\fR type.
The first member of the structure must be a null-terminated string.
The size of the structure is given by \fIoffset\fR.
Note that references to the \fIstructTablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array of structures.
.AP int offset in
The offset to add to structTablePtr to get to the next entry.
The end of the array is marked by a NULL string pointer.
.AP "const char" *msg in
Null-terminated string describing what is being looked up, such as
\fBoption\fR. This string is included in error messages.
.AP int flags in
OR-ed combination of bits providing additional information for
operation. The only bit that is currently defined is \fBTCL_EXACT\fR.
.AP int *indexPtr out
The index of the string in \fItablePtr\fR that matches the value of
\fIobjPtr\fR is returned here.
.BE
.SH DESCRIPTION
.PP
These procedures provide an efficient way for looking up keywords,
switch names, option names, and similar things where the literal value of
a Tcl value must be chosen from a predefined set.
\fBTcl_GetIndexFromObj\fR compares \fIobjPtr\fR against each of
the strings in \fItablePtr\fR to find a match. A match occurs if
\fIobjPtr\fR's string value is identical to one of the strings in
\fItablePtr\fR, or if it is a non-empty unique abbreviation
for exactly one of the strings in \fItablePtr\fR and the
\fBTCL_EXACT\fR flag was not specified; in either case
the index of the matching entry is stored at \fI*indexPtr\fR
and \fBTCL_OK\fR is returned.
|
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS | | | 97 98 99 100 101 102 103 104 | array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS index, option, value, table lookup |
Changes to doc/Hash.3.
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
.PP
.CS
typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
.PP
| | | | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
.PP
.CS
typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
.PP
If this is NULL then \fBTcl_Alloc\fR is used to allocate enough space for a
Tcl_HashEntry, the key pointer is assigned to key.oneWordValue and the
clientData is set to NULL. String keys and array keys use this function to
allocate enough space for the entry and the key in one block, rather than
doing it in two blocks. This saves space for a pointer to the key from the
entry and another memory allocation. Tcl_Obj* keys use this function to
allocate enough space for an entry and increment the reference count on the
value.
.PP
The \fIfreeEntryProc\fR member contains the address of a function called to
free space for an entry.
.PP
.CS
typedef void \fBTcl_FreeHashEntryProc\fR(
Tcl_HashEntry *\fIhPtr\fR);
.CE
.PP
If this is NULL then \fBTcl_Free\fR is used to free the space for the entry.
Tcl_Obj* keys use this function to decrement the reference count on the
value.
.SH KEYWORDS
hash table, key, lookup, search, value
|
Changes to doc/InitStubs.3.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard | | | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the library name is \fItclstub86.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for more information. .SH DESCRIPTION \fBTcl_InitStubs\fR attempts to initialize the stub table pointers |
| ︙ | ︙ |
Changes to doc/IntObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .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 .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in | | | | | | | | | | | | | | > | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR, this points to the value in which to store an integral value. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR, this refers to the value from which to retrieve an integral value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when integral value retrieval fails. .AP int *intPtr out Points to place to store the integer value retrieved from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out Points to a multi-precision integer structure declared by the LibTomMath library. .AP double doubleValue in Double value from which the integer part is determined and used to initialize a multi-precision integer value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl values that hold integral values. .PP The different routines exist to accommodate different integral types in C with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types 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, \fBint64\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new Tcl value initialized to the integral value of the argument. The returned Tcl value is unshared. .PP The \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR routines each set the value of an existing Tcl value pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value 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_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral value of the appropriate type 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 integral value, or if the value exceeds the range of the target type. 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. Unlike the other functions, \fBTcl_TakeBignumFromObj\fR may set the content of the Tcl value \fIobjPtr\fR to an empty string in the process of retrieving the multiple-precision integer value. .PP The choice between \fBTcl_GetBignumFromObj\fR and \fBTcl_TakeBignumFromObj\fR is governed by how the caller will continue to use \fIobjPtr\fR. If after the \fBmp_int\fR value is retrieved from \fIobjPtr\fR, the caller will make no more use of \fIobjPtr\fR, then using \fBTcl_TakeBignumFromObj\fR permits Tcl to detect when an unshared \fIobjPtr\fR permits the value to be moved instead of copied, which should be more efficient. If anything later in the caller requires \fIobjPtr\fR to continue to hold the same value, then \fBTcl_GetBignumFromObj\fR must be chosen. .PP The \fBTcl_InitBignumFromDouble\fR routine is a utility procedure that extracts the integer part of \fIdoubleValue\fR and stores that integer value in the \fBmp_int\fR value \fIbigValue\fR. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS integer, integer value, integer type, internal representation, value, value type, string representation |
Changes to doc/ListObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl values as lists .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_ListObjAppendList\fR(\fIinterp, listPtr, elemListPtr\fR) .sp |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | \fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR) .sp int \fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *elemListPtr in/out .AP Tcl_Interp *interp in | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
\fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR)
.sp
int
\fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR)
.SH ARGUMENTS
.AS "Tcl_Obj *const" *elemListPtr in/out
.AP Tcl_Interp *interp in
If an error occurs while converting a value to be a list value,
an error message is left in the interpreter's result value
unless \fIinterp\fR is NULL.
.AP Tcl_Obj *listPtr in/out
Points to the list value to be manipulated.
If \fIlistPtr\fR does not already point to a list value,
an attempt will be made to convert it to one.
.AP Tcl_Obj *elemListPtr in/out
For \fBTcl_ListObjAppendList\fR, this points to a list value
containing elements to be appended onto \fIlistPtr\fR.
Each element of *\fIelemListPtr\fR will
become a new element of \fIlistPtr\fR.
If *\fIelemListPtr\fR is not NULL and
does not already point to a list value,
an attempt will be made to convert it to one.
.AP Tcl_Obj *objPtr in
For \fBTcl_ListObjAppendElement\fR,
points to the Tcl value that will be appended to \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
this points to the Tcl value that will be converted to a list value
containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR.
.AP int *objcPtr in
Points to location where \fBTcl_ListObjGetElements\fR
stores the number of element values in \fIlistPtr\fR.
.AP Tcl_Obj ***objvPtr out
A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array
of pointers to the element values of \fIlistPtr\fR.
.AP int objc in
The number of Tcl values that \fBTcl_NewListObj\fR
will insert into a new list value,
and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
the number of Tcl values to insert into \fIobjPtr\fR.
.AP "Tcl_Obj *const" objv[] in
An array of pointers to values.
\fBTcl_NewListObj\fR will insert these values into a new list value
and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR.
Each value will become a separate list element.
.AP int *intPtr out
Points to location where \fBTcl_ListObjLength\fR
stores the length of the list.
.AP int index in
Index of the list element that \fBTcl_ListObjIndex\fR
is to return.
The first element has index 0.
.AP Tcl_Obj **objPtrPtr out
Points to place where \fBTcl_ListObjIndex\fR is to store
a pointer to the resulting list element value.
.AP int first in
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
.AP int count in
The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE
.SH DESCRIPTION
.PP
Tcl list values have an internal representation that supports
the efficient indexing and appending.
The procedures described in this man page are used to
create, modify, index, and append to Tcl list values from C code.
.PP
\fBTcl_ListObjAppendList\fR and \fBTcl_ListObjAppendElement\fR
both add one or more values
to the end of the list value referenced by \fIlistPtr\fR.
\fBTcl_ListObjAppendList\fR appends each element of the list value
referenced by \fIelemListPtr\fR while
\fBTcl_ListObjAppendElement\fR appends the single value
referenced by \fIobjPtr\fR.
Both procedures will convert the value referenced by \fIlistPtr\fR
to a list value if necessary.
If an error occurs during conversion,
both procedures return \fBTCL_ERROR\fR and leave an error message
in the interpreter's result value if \fIinterp\fR is not NULL.
Similarly, if \fIelemListPtr\fR does not already refer to a list value,
\fBTcl_ListObjAppendList\fR will attempt to convert it to one
and if an error occurs during conversion,
will return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result value
if interp is not NULL.
Both procedures invalidate any old string representation of \fIlistPtr\fR
and, if it was converted to a list value,
free any old internal representation.
Similarly, \fBTcl_ListObjAppendList\fR frees any old internal representation
of \fIelemListPtr\fR if it converts it to a list value.
After appending each element in \fIelemListPtr\fR,
\fBTcl_ListObjAppendList\fR increments the element's reference count
since \fIlistPtr\fR now also refers to it.
For the same reason, \fBTcl_ListObjAppendElement\fR
increments \fIobjPtr\fR's reference count.
If no error occurs,
the two procedures return \fBTCL_OK\fR after appending the values.
.PP
\fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR
create a new value or modify an existing value to hold
the \fIobjc\fR elements of the array referenced by \fIobjv\fR
where each element is a pointer to a Tcl value.
If \fIobjc\fR is less than or equal to zero,
they return an empty value.
The new value's string representation is left invalid.
The two procedures increment the reference counts
of the elements in \fIobjc\fR since the list value now refers to them.
The new list value returned by \fBTcl_NewListObj\fR
has reference count zero.
.PP
\fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of
the elements in a list value. It returns the count by storing it in the
address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing
it in the address \fIobjvPtr\fR.
The memory pointed to is managed by Tcl and should not be freed or written
to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR
and NULL at \fIobjvPtr\fR.
If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR
will attempt to convert it to one; if the conversion fails, it returns
\fBTCL_ERROR\fR and leaves an error message in the interpreter's result
value if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer.
.PP
\fBTcl_ListObjLength\fR returns the number of elements in the list value
referenced by \fIlistPtr\fR.
It returns this count by storing an integer in the address \fIintPtr\fR.
If the value is not already a list value,
\fBTcl_ListObjLength\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the list's length.
.PP
The procedure \fBTcl_ListObjIndex\fR returns a pointer to the value
at element \fIindex\fR in the list referenced by \fIlistPtr\fR.
It returns this value by storing a pointer to it
in the address \fIobjPtrPtr\fR.
If \fIlistPtr\fR does not already refer to a list value,
\fBTcl_ListObjIndex\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
If the index is out of range,
that is, \fIindex\fR is negative or
greater than or equal to the number of elements in the list,
\fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR
and returns \fBTCL_OK\fR.
Otherwise it returns \fBTCL_OK\fR after storing the element's
value pointer.
The reference count for the list element is not incremented;
the caller must do that if it needs to retain a pointer to the element.
.PP
\fBTcl_ListObjReplace\fR replaces zero or more elements
of the list referenced by \fIlistPtr\fR
with the \fIobjc\fR values in the array referenced by \fIobjv\fR.
If \fIlistPtr\fR does not point to a list value,
\fBTcl_ListObjReplace\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise, it returns \fBTCL_OK\fR after replacing the values.
If \fIobjv\fR is NULL, no new elements are added.
If the argument \fIfirst\fR is zero or negative,
it refers to the first element.
If \fIfirst\fR is greater than or equal to the
number of elements in the list, then no elements are deleted;
the new elements are appended to the list.
\fIcount\fR gives the number of elements to replace.
If \fIcount\fR is zero or negative then no elements are deleted;
the new elements are simply inserted before the one
designated by \fIfirst\fR.
\fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's
old string representation.
The reference counts of any elements inserted from \fIobjv\fR
are incremented since the resulting list now refers to them.
Similarly, the reference counts for any replaced values are decremented.
.PP
Because \fBTcl_ListObjReplace\fR combines
both element insertion and deletion,
it can be used to implement a number of list operations.
For example, the following code inserts the \fIobjc\fR values
referenced by the array of value pointers \fIobjv\fR
just before the element \fIindex\fR of the list referenced by \fIlistPtr\fR:
.PP
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, index, 0,
objc, objv);
.CE
.PP
Similarly, the following code appends the \fIobjc\fR values
referenced by the array \fIobjv\fR
to the end of the list \fIlistPtr\fR:
.PP
.CS
result = \fBTcl_ListObjLength\fR(interp, listPtr, &length);
if (result == TCL_OK) {
result = \fBTcl_ListObjReplace\fR(interp, listPtr, length, 0,
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
| | > | 243 244 245 246 247 248 249 250 251 |
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
append, index, insert, internal representation, length, list, list value,
list type, value, value type, replace, string representation
|
Changes to doc/Load.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | The name of the file to load. If it is a single name, the library search path of the current environment will be used to resolve it. .AP "const char *const" symbols[] in Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in | | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | The name of the file to load. If it is a single name, the library search path of the current environment will be used to resolve it. .AP "const char *const" symbols[] in Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in The value should normally be 0, but \fITCL_LOAD_GLOBAL\fR or \fITCL_LOAD_LAZY\fR or a combination of those two is allowed as well. .AP void *procPtrs out Points to an array that will hold the addresses of the functions described in the \fIsymbols\fR argument. Should be NULL if no symbols are to be resolved. .AP Tcl_LoadHandle *loadHandlePtr out Points to a variable that will hold the handle to the abstract token describing the library that has been loaded. .AP Tcl_LoadHandle loadHandle in |
| ︙ | ︙ |
Changes to doc/NRE.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | .AP Tcl_CmdDeleteProc *deleteProc in/out Procedure to call before \fIcmdName\fR is deleted from the interpreter. This procedure allows for command-specific cleanup. If \fIdeleteProc\fR is \fBNULL\fR, then no procedure is called before the command is deleted. .AP int objc in Count of parameters provided to the implementation of a command. .AP Tcl_Obj **objv in | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .AP Tcl_CmdDeleteProc *deleteProc in/out Procedure to call before \fIcmdName\fR is deleted from the interpreter. This procedure allows for command-specific cleanup. If \fIdeleteProc\fR is \fBNULL\fR, then no procedure is called before the command is deleted. .AP int objc in Count of parameters provided to the implementation of a command. .AP Tcl_Obj **objv in Pointer to an array of Tcl values. Each value holds the value of a single word in the command to execute. .AP Tcl_Obj *objPtr in Pointer to a Tcl_Obj whose value is a script or expression to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported. .\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and |
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | invoke a single Tcl command whose words have already been separated and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the words of the command to be evaluated when execution reaches the trampoline. .PP \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose resolution is already known. The \fIcmd\fR parameter gives a | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | invoke a single Tcl command whose words have already been separated and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the words of the command to be evaluated when execution reaches the trampoline. .PP \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose resolution is already known. The \fIcmd\fR parameter gives a \fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or \fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in the trampoline; this command must match the word in \fIobjv[0]\fR. The remaining arguments are as for \fBTcl_NREvalObj\fR. .PP \fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR all accept a \fIflags\fR parameter, which is an OR-ed-together set of bits to control evaluation. At the present time, the only supported flag |
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
| | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
* passed to \fBTcl_NRAddCallback\fR */
\fI... postprocessing ...\fR
return result;
}
.CE
.PP
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
| | | 319 320 321 322 323 324 325 326 327 328 |
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
stackless, nonrecursive, execute, command, global, value, result, script
.SH COPYRIGHT
Copyright (c) 2008 by Kevin B. Kenny
|
Changes to doc/Namespace.3.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out A reference to an unshared value to which the function output will be written. .AP "const char" *pattern in The glob-style pattern (see \fBTcl_StringMatch\fR) that describes the commands to be imported or exported. .AP int resetListFirst in Whether the list of export patterns should be reset before adding the current pattern to it. |
| ︙ | ︙ |
Changes to doc/Object.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewObj\fR() .sp |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp \fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in | | | > | | | | | | | | | | | | | | | | | | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
int
\fBTcl_IsShared\fR(\fIobjPtr\fR)
.sp
\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)
.SH ARGUMENTS
.AS Tcl_Obj *objPtr
.AP Tcl_Obj *objPtr in
Points to a value;
must have been the result of a previous call to \fBTcl_NewObj\fR.
.BE
.SH INTRODUCTION
.PP
This man page presents an overview of Tcl values (called \fBTcl_Obj\fRs for
historical reasons) and how they are used.
It also describes generic procedures for managing Tcl values.
These procedures are used to create and copy values,
and increment and decrement the count of references (pointers) to values.
The procedures are used in conjunction with ones
that operate on specific types of values such as
\fBTcl_GetIntFromObj\fR and \fBTcl_ListObjAppendElement\fR.
The individual procedures are described along with the data structures
they manipulate.
.PP
Tcl's \fIdual-ported\fR values provide a general-purpose mechanism
for storing and exchanging Tcl values.
They largely replace the use of strings in Tcl.
For example, they are used to store variable values,
command arguments, command results, and scripts.
Tcl values behave like strings but also hold an internal representation
that can be manipulated more efficiently.
For example, a Tcl list is now represented as a value
that holds the list's string representation
as well as an array of pointers to the values for each list element.
Dual-ported values avoid most runtime type conversions.
They also improve the speed of many operations
since an appropriate representation is immediately available.
The compiler itself uses Tcl values to
cache the instruction bytecodes resulting from compiling scripts.
.PP
The two representations are a cache of each other and are computed lazily.
That is, each representation is only computed when necessary,
it is computed from the other representation,
and, once computed, it is saved.
In addition, a change in one representation invalidates the other one.
As an example, a Tcl program doing integer calculations can
operate directly on a variable's internal machine integer
representation without having to constantly convert
between integers and strings.
Only when it needs a string representing the variable's value,
say to print it,
will the program regenerate the string representation from the integer.
Although values contain an internal representation,
their semantics are defined in terms of strings:
an up-to-date string can always be obtained,
and any change to the value will be reflected in that string
when the value's string representation is fetched.
Because of this representation invalidation and regeneration,
it is dangerous for extension writers to access
\fBTcl_Obj\fR fields directly.
It is better to access Tcl_Obj information using
procedures like \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR.
.PP
Values are allocated on the heap
and are referenced using a pointer to their \fBTcl_Obj\fR structure.
Values are shared as much as possible.
This significantly reduces storage requirements
because some values such as long lists are very large.
Also, most Tcl values are only read and never modified.
This is especially true for procedure arguments,
which can be shared between the caller and the called procedure.
Assignment and argument binding is done by
simply assigning a pointer to the value.
Reference counting is used to determine when it is safe to
reclaim a value's storage.
.PP
Tcl values are typed.
A value's internal representation is controlled by its type.
Several types are predefined in the Tcl core
including integer, double, list, and bytecode.
Extension writers can extend the set of types
by defining their own \fBTcl_ObjType\fR structs.
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
int \fIrefCount\fR;
char *\fIbytes\fR;
int \fIlength\fR;
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
a value's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
this allows string representations
to be treated as conventional null-terminated C strings.
C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
a value's string representation.
If \fIbytes\fR is NULL,
the string representation is invalid.
.PP
A value's type manages its internal representation.
The member \fItypePtr\fR points to the Tcl_ObjType structure
that describes the type.
If \fItypePtr\fR is NULL,
the internal representation is invalid.
.PP
The \fIinternalRep\fR union member holds
a value's internal representation.
This is either a (long) integer, a double-precision floating-point number,
a pointer to a value containing additional information
needed by the value's type to represent the value, a Tcl_WideInt
integer, two arbitrary pointers, or a pair made up of an unsigned long
integer and a pointer.
.PP
The \fIrefCount\fR member is used to tell when it is safe to free
a value's storage.
It holds the count of active references to the value.
Maintaining the correct reference count is a key responsibility
of extension writers.
Reference counting is discussed below
in the section \fBSTORAGE MANAGEMENT OF VALUES\fR.
.PP
Although extension writers can directly access
the members of a Tcl_Obj structure,
it is much better to use the appropriate procedures and macros.
For example, extension writers should never
read or update \fIrefCount\fR directly;
they should use macros such as
\fBTcl_IncrRefCount\fR and \fBTcl_IsShared\fR instead.
.PP
A key property of Tcl values is that they hold two representations.
A value typically starts out containing only a string representation:
it is untyped and has a NULL \fItypePtr\fR.
A value containing an empty string or a copy of a specified string
is created using \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR respectively.
A value's string value is gotten with
\fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR
and changed with \fBTcl_SetStringObj\fR.
If the value is later passed to a procedure like \fBTcl_GetIntFromObj\fR
that requires a specific internal representation,
the procedure will create one and set the value's \fItypePtr\fR.
The internal representation is computed from the string representation.
A value's two representations are duals of each other:
changes made to one are reflected in the other.
For example, \fBTcl_ListObjReplace\fR will modify a value's
internal representation and the next call to \fBTcl_GetStringFromObj\fR
or \fBTcl_GetString\fR will reflect that change.
.PP
Representations are recomputed lazily for efficiency.
A change to one representation made by a procedure
such as \fBTcl_ListObjReplace\fR is not reflected immediately
in the other representation.
Instead, the other representation is marked invalid
so that it is only regenerated if it is needed later.
Most C programmers never have to be concerned with how this is done
and simply use procedures such as \fBTcl_GetBooleanFromObj\fR or
\fBTcl_ListObjIndex\fR.
Programmers that implement their own value types
must check for invalid representations
and mark representations invalid when necessary.
The procedure \fBTcl_InvalidateStringRep\fR is used
to mark a value's string representation invalid and to
free any storage associated with the old string representation.
.PP
Values usually remain one type over their life,
but occasionally a value must be converted from one type to another.
For example, a C program might build up a string in a value
with repeated calls to \fBTcl_AppendToObj\fR,
and then call \fBTcl_ListObjIndex\fR to extract a list element from
the value.
The same value holding the same string value
can have several different internal representations
at different times.
Extension writers can also force a value to be converted from one type
to another using the \fBTcl_ConvertToType\fR procedure.
Only programmers that create new value types need to be concerned
about how this is done.
A procedure defined as part of the value type's implementation
creates a new internal representation for a value
and changes its \fItypePtr\fR.
See the man page for \fBTcl_RegisterObjType\fR
to see how to create a new value type.
.SH "EXAMPLE OF THE LIFETIME OF A VALUE"
.PP
As an example of the lifetime of a value,
consider the following sequence of commands:
.PP
.CS
\fBset x 123\fR
.CE
.PP
This assigns to \fIx\fR an untyped value whose
\fIbytes\fR member points to \fB123\fR and \fIlength\fR member contains 3.
The value's \fItypePtr\fR member is NULL.
.PP
.CS
\fBputs "x is $x"\fR
.CE
.PP
\fIx\fR's string representation is valid (since \fIbytes\fR is non-NULL)
and is fetched for the command.
.PP
.CS
\fBincr x\fR
.CE
.PP
The \fBincr\fR command first gets an integer from \fIx\fR's value
by calling \fBTcl_GetIntFromObj\fR.
This procedure checks whether the value is already an integer value.
Since it is not, it converts the value
by setting the value's \fIinternalRep.longValue\fR member
to the integer \fB123\fR
and setting the value's \fItypePtr\fR
to point to the integer Tcl_ObjType structure.
Both representations are now valid.
\fBincr\fR increments the value's integer internal representation
then invalidates its string representation
(by calling \fBTcl_InvalidateStringRep\fR)
since the string representation
no longer corresponds to the internal representation.
.PP
.CS
\fBputs "x is now $x"\fR
.CE
.PP
The string representation of \fIx\fR's value is needed
and is recomputed.
The string representation is now \fB124\fR
and both representations are again valid.
.SH "STORAGE MANAGEMENT OF VALUES"
.PP
Tcl values are allocated on the heap and are shared as much as possible
to reduce storage requirements.
Reference counting is used to determine when a value is
no longer needed and can safely be freed.
A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR
has \fIrefCount\fR 0.
The macro \fBTcl_IncrRefCount\fR increments the reference count
when a new reference to the value is created.
The macro \fBTcl_DecrRefCount\fR decrements the count
when a reference is no longer needed and,
if the value's reference count drops to zero, frees its storage.
A value shared by different code or data structures has
\fIrefCount\fR greater than 1.
Incrementing a value's reference count ensures that
it will not be freed too early or have its value change accidentally.
.PP
As an example, the bytecode interpreter shares argument values
between calling and called Tcl procedures to avoid having to copy values.
It assigns the call's argument values to the procedure's
formal parameter variables.
In doing so, it calls \fBTcl_IncrRefCount\fR to increment
the reference count of each argument since there is now a new
reference to it from the formal parameter.
When the called procedure returns,
the interpreter calls \fBTcl_DecrRefCount\fR to decrement
each argument's reference count.
When a value's reference count drops less than or equal to zero,
\fBTcl_DecrRefCount\fR reclaims its storage.
Most command procedures do not have to be concerned about
reference counting since they use a value's value immediately
and do not retain a pointer to the value after they return.
However, if they do retain a pointer to a value in a data structure,
they must be careful to increment its reference count
since the retained pointer is a new reference.
.PP
Command procedures that directly modify values
such as those for \fBlappend\fR and \fBlinsert\fR must be careful to
copy a shared value before changing it.
They must first check whether the value is shared
by calling \fBTcl_IsShared\fR.
If the value is shared they must copy the value
by using \fBTcl_DuplicateObj\fR;
this returns a new duplicate of the original value
that has \fIrefCount\fR 0.
If the value is not shared,
the command procedure
.QW "owns"
the value and can safely modify it directly.
For example, the following code appears in the command procedure
that implements \fBlinsert\fR.
This procedure modifies the list value passed to it in \fIobjv[1]\fR
by inserting \fIobjc-3\fR new elements before \fIindex\fR.
.PP
.CS
listPtr = objv[1];
if (\fBTcl_IsShared\fR(listPtr)) {
listPtr = \fBTcl_DuplicateObj\fR(listPtr);
}
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]));
.CE
.PP
As another example, \fBincr\fR's command procedure
must check whether the variable's value is shared before
incrementing the integer in its internal representation.
If it is shared, it needs to duplicate the value
in order to avoid accidentally changing values in other data structures.
.SH "SEE ALSO"
Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3)
.SH KEYWORDS
internal representation, value, value creation, value type,
reference counting, string representation, type conversion
|
Changes to doc/ObjectType.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | > | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl value types .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_RegisterObjType\fR(\fItypePtr\fR) .sp const Tcl_ObjType * \fBTcl_GetObjType\fR(\fItypeName\fR) .sp int \fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR) .SH ARGUMENTS .AS "const char" *typeName .AP "const Tcl_ObjType" *typePtr in Points to the structure containing information about the Tcl value type. This storage must live forever, typically by being statically allocated. .AP "const char" *typeName in The name of a Tcl value type that \fBTcl_GetObjType\fR should look up. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP Tcl_Obj *objPtr in For \fBTcl_AppendAllObjTypes\fR, this points to the value onto which it appends the name of each value type as a list element. For \fBTcl_ConvertToType\fR, this points to a value that must have been the result of a previous call to \fBTcl_NewObj\fR. .BE .SH DESCRIPTION .PP The procedures in this man page manage Tcl value types (sometimes referred to as object types or \fBTcl_ObjType\fRs for historical reasons). They are used to register new value types, look up types, and force conversions from one type to another. .PP \fBTcl_RegisterObjType\fR registers a new Tcl value type in the table of all value types that \fBTcl_GetObjType\fR can look up by name. There are other value types supported by Tcl as well, which Tcl chooses not to register. Extensions can likewise choose to register the value types they create or not. The argument \fItypePtr\fR points to a Tcl_ObjType structure that describes the new type by giving its name and by supplying pointers to four procedures that implement the type. If the type table already contains a type with the same name as in \fItypePtr\fR, it is replaced with the new type. The Tcl_ObjType structure is described in the section \fBTHE TCL_OBJTYPE STRUCTURE\fR below. .PP \fBTcl_GetObjType\fR returns a pointer to the registered Tcl_ObjType with name \fItypeName\fR. It returns NULL if no type with that name is registered. .PP \fBTcl_AppendAllObjTypes\fR appends the name of each registered value type as a list element onto the Tcl value referenced by \fIobjPtr\fR. The return value is \fBTCL_OK\fR unless there was an error converting \fIobjPtr\fR to a list value; in that case \fBTCL_ERROR\fR is returned. .PP \fBTcl_ConvertToType\fR converts a value from one type to another if possible. It creates a new internal representation for \fIobjPtr\fR appropriate for the target type \fItypePtr\fR and sets its \fItypePtr\fR member as determined by calling the \fItypePtr->setFromAnyProc\fR routine. Any internal representation for \fIobjPtr\fR's old type is freed. If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the result value for \fIinterp\fR unless \fIinterp\fR is NULL. Otherwise, it returns \fBTCL_OK\fR. Passing a NULL \fIinterp\fR allows this procedure to be used as a test whether the conversion can be done (and in fact was done). .VS 8.5 .PP In many cases, the \fItypePtr->setFromAnyProc\fR routine will set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR, but that is no longer guaranteed. The \fIsetFromAnyProc\fR is free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. .VE 8.5 .SH "THE TCL_OBJTYPE STRUCTURE" .PP Extension writers can define new value types by defining four procedures and initializing a Tcl_ObjType structure to describe the type. Extension writers may also pass a pointer to their Tcl_ObjType structure to \fBTcl_RegisterObjType\fR if they wish to permit other extensions to look up their Tcl_ObjType by name with the \fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is defined as follows: |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | .SS "THE NAME FIELD" .PP The \fIname\fR member describes the name of the type, e.g. \fBint\fR. When a type is registered, this is the name used by callers of \fBTcl_GetObjType\fR to lookup the type. For unregistered types, the \fIname\fR field is primarily of value for debugging. The remaining four members are pointers to procedures | | | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
.SS "THE NAME FIELD"
.PP
The \fIname\fR member describes the name of the type, e.g. \fBint\fR.
When a type is registered, this is the name used by callers
of \fBTcl_GetObjType\fR to lookup the type. For unregistered
types, the \fIname\fR field is primarily of value for debugging.
The remaining four members are pointers to procedures
called by the generic Tcl value code:
.SS "THE SETFROMANYPROC FIELD"
.PP
The \fIsetFromAnyProc\fR member contains the address of a function
called to create a valid internal representation
from a value's string representation.
.PP
.CS
typedef int \fBTcl_SetFromAnyProc\fR(
Tcl_Interp *\fIinterp\fR,
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
If an internal representation cannot be created from the string,
it returns \fBTCL_ERROR\fR and puts a message
describing the error in the result value for \fIinterp\fR
unless \fIinterp\fR is NULL.
If \fIsetFromAnyProc\fR is successful,
it stores the new internal representation,
sets \fIobjPtr\fR's \fItypePtr\fR member to point to
the \fBTcl_ObjType\fR struct corresponding to the new
internal representation, and returns \fBTCL_OK\fR.
Before setting the new internal representation,
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will lead to a panic, so to avoid this possibility, the type should \fInot\fR be registered. .SS "THE UPDATESTRINGPROC FIELD" .PP The \fIupdateStringProc\fR member contains the address of a function called to create a valid string representation | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will
lead to a panic, so to avoid this possibility, the type
should \fInot\fR be registered.
.SS "THE UPDATESTRINGPROC FIELD"
.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
from a value's internal representation.
.PP
.CS
typedef void \fBTcl_UpdateStringProc\fR(
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
\fIobjPtr\fR's \fIbytes\fR member is always NULL when it is called.
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | making use of the internal representation are written so that the string representation is never invalidated. Failure to meet this obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR or other similar routines ask for the string representation. .SS "THE DUPINTREPPROC FIELD" .PP The \fIdupIntRepProc\fR member contains the address of a function | | | | | | | | | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
making use of the internal representation are written so that the
string representation is never invalidated. Failure to meet this
obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR
or other similar routines ask for the string representation.
.SS "THE DUPINTREPPROC FIELD"
.PP
The \fIdupIntRepProc\fR member contains the address of a function
called to copy an internal representation from one value to another.
.PP
.CS
typedef void \fBTcl_DupInternalRepProc\fR(
Tcl_Obj *\fIsrcPtr\fR,
Tcl_Obj *\fIdupPtr\fR);
.CE
.PP
\fIdupPtr\fR's internal representation is made a copy of \fIsrcPtr\fR's
internal representation.
Before the call,
\fIsrcPtr\fR's internal representation is valid and \fIdupPtr\fR's is not.
\fIsrcPtr\fR's value type determines what
copying its internal representation means.
.PP
For example, the \fIdupIntRepProc\fR for the Tcl integer type
simply copies an integer.
The built-in list type's \fIdupIntRepProc\fR uses a far more
sophisticated scheme to continue sharing storage as much as it
reasonably can.
.SS "THE FREEINTREPPROC FIELD"
.PP
The \fIfreeIntRepProc\fR member contains the address of a function
that is called when a value is freed.
.PP
.CS
typedef void \fBTcl_FreeInternalRepProc\fR(
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
The \fIfreeIntRepProc\fR function can deallocate the storage
for the value's internal representation
and do other type-specific processing necessary when a value is freed.
.PP
For example, the list type's \fIfreeIntRepProc\fR respects
the storage sharing scheme established by the \fIdupIntRepProc\fR
so that it only frees storage when the last value sharing it
is being freed.
.PP
The \fIfreeIntRepProc\fR member can be set to NULL
to indicate that the internal representation does not require freeing.
The \fIfreeIntRepProc\fR implementation must not access the
\fIbytes\fR member of the value, since Tcl makes its own internal
uses of that field during value deletion. The defined tasks for
the \fIfreeIntRepProc\fR have no need to consult the \fIbytes\fR
member.
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3)
.SH KEYWORDS
internal representation, value, value type, string representation, type conversion
|
Changes to doc/OpenFileChnl.3.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out | | | | | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. .AP int charsToRead in The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. .AP int bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl value in which to store the line read from the channel. The line read will be appended to the current value of the value. .AP Tcl_DString *lineRead in/out A pointer to a Tcl dynamic string in which to store the line read from the channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. .AP int inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or beginning of the channel buffer. .AP Tcl_Obj *writeObjPtr in A pointer to a Tcl value whose contents will be output to the channel. .AP "const char" *charBuf in A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. .AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. |
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. As of Tcl 8.4, the value-based API \fBTcl_FSOpenFileChannel\fR should be used in preference to \fBTcl_OpenFileChannel\fR wherever possible. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. 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. |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a list value. \fBTcl_GetChannelNamesEx\fR will filter these names according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it will not do any filtering. The return value is \fBTCL_OK\fR if no errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR, and the error message is left in the interpreter's result. .SH TCL_REGISTERCHANNEL .PP \fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible |
| ︙ | ︙ | |||
431 432 433 434 435 436 437 | end-of-line recognition mode. End-of-line recognition and the various platform-specific modes are described in the manual entry for the Tcl \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a | | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 | end-of-line recognition mode. End-of-line recognition and the various platform-specific modes are described in the manual entry for the Tcl \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a byte-array value. The string representation of this value will only be constructed if it is needed (e.g., because of a call to \fBTcl_GetStringFromObj\fR). In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it does not do |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | no data was available or the data that was available did not contain an end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | no data was available or the data that was available did not contain an end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by \fIlineRead\fR rather than a Tcl value. .SH "TCL_UNGETS" .PP \fBTcl_Ungets\fR is used to add data to the input queue of a channel, at either the head or tail of the queue. The pointer \fIinput\fR points to the data that is to be added. The length of the input to add is given by \fIinputLen\fR. A non-zero value of \fIaddAtEnd\fR indicates that the data is to be added at the end of queue; otherwise it will be added at the |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it accepts a Tcl value whose contents will be output to the channel. The UTF-8 characters in \fIwriteObjPtr\fR's string representation are converted to the channel's encoding and queued for output to \fIchannel\fR. As a performance optimization, when writing to a channel with the encoding \fBbinary\fR, UTF-8 characters are not converted as they are written. Instead, the bytes in \fIwriteObjPtr\fR's internal representation as a byte-array value are written to the channel. The byte-array representation of the value will be constructed if it is needed. In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it does not do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized |
| ︙ | ︙ |
Changes to doc/ParseArgs.3.
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
| | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
\fIobjPtr\fR is the value that represents the following argument or NULL if
there are no following arguments at all, and the \fIdstPtr\fR argument to the
\fBTcl_ArgvFuncProc\fR is the location to write the parsed value to.
.RE
.TP
\fBTCL_ARGV_GENFUNC\fR
.
This argument takes zero or more following arguments; the handler callback
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. .TP \fBTCL_ARGV_STRING\fR . This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. .TP \fBTCL_ARGV_STRING\fR . This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked to the lifetime of the string representation of the argument value that it came from, and so should be copied if it needs to be retained. The \fIsrcPtr\fR and \fIclientData\fR fields are ignored. .SH "SEE ALSO" Tcl_GetIndexFromObj(3), Tcl_Main(3), Tcl_CreateObjCommand(3) .SH KEYWORDS argument, parse '\" Local Variables: '\" fill-column: 78 '\" End: |
Changes to doc/ParseCmd.3.
| ︙ | ︙ | |||
190 191 192 193 194 195 196 | \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. | | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. The reference count of the value returned as result has been incremented, so the caller must invoke \fBTcl_DecrRefCount\fR when it is finished with the value. If an error or other exception occurs while evaluating the tokens (such as a reference to a non-existent variable) then the return value is NULL and an error message is left in \fIinterp\fR's result. The use of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, |
| ︙ | ︙ |
Changes to doc/RecEvalObj.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in Points to a Tcl value containing a command (or sequence of commands) to execute. .AP int flags in An OR'ed combination of flag bits. \fBTCL_NO_EVAL\fR means record the command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .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) that can be retrieved using \fBTcl_GetObjResult\fR. If you do not want the command recorded on the history list then you should invoke \fBTcl_EvalObjEx\fR instead of \fBTcl_RecordAndEvalObj\fR. Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .SH "SEE ALSO" Tcl_EvalObjEx, Tcl_GetObjResult .SH KEYWORDS command, event, execute, history, interpreter, value, record |
Changes to doc/RecordEval.3.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the | | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the value-based procedure \fBTcl_RecordAndEvalObj\fR. That value-based procedure records and optionally executes a command held in a Tcl value instead of a string. .SH "SEE ALSO" Tcl_RecordAndEvalObj .SH KEYWORDS command, event, execute, history, interpreter, record |
Changes to doc/RegExp.3.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | .fi .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out | | | | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | .fi .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out Refers to the value from which to get the text to search. The internal representation of the value may be converted to a form that can be efficiently searched. .AP Tcl_Obj *patObj in/out Refers to the value from which to get a regular expression. The compiled regular expression is cached in the value. .AP char *text in Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it operates on the Tcl values \fItextObj\fR and \fIpatObj\fR instead of UTF strings. \fBTcl_RegExpMatchObj\fR is generally more efficient than \fBTcl_RegExpMatch\fR, so it is the preferred interface. .PP \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR provide lower-level access to the regular expression pattern matcher. \fBTcl_RegExpCompile\fR compiles a regular expression string into |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and | | | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and \fBTcl_RegExpGetInfo\fR are value interfaces that provide the most direct control of Henry Spencer's regular expression library. For users that need to modify compilation and execution options directly, it is recommended that you use these interfaces instead of calling the internal regexp functions. These interfaces handle the details of UTF to Unicode translations as well as providing improved performance through caching in the pattern and string values. .PP \fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular expression from the \fIpatObj\fR. If the value does not already contain a compiled regular expression it will attempt to create one from the string in the value and assign it to the internal representation of the \fIpatObj\fR. The return value of this function is of type \fBTcl_RegExp\fR. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR. If an error occurs while compiling the regular expression then \fBTcl_GetRegExpFromObj\fR returns NULL and leaves an error message in the interpreter result. The regular expression token can be used as |
| ︙ | ︙ |
Changes to doc/SaveResult.3.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | .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 | | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | .PP The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. .PP \fBTcl_SaveResult\fR moves the string and value results of \fIinterp\fR into the location specified by \fIstatePtr\fR. \fBTcl_SaveResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. .PP \fBTcl_RestoreResult\fR moves the string and value results from \fIstatePtr\fR back into \fIinterp\fR. Any result or error that was already in the interpreter will be cleared. The \fIstatePtr\fR is left in an uninitialized state and cannot be used until another call to \fBTcl_SaveResult\fR. .PP \fBTcl_DiscardResult\fR releases the saved interpreter state stored at \fBstatePtr\fR. The state structure is left in an |
| ︙ | ︙ |
Changes to doc/SetChanErr.3.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | to place arbitrary error messages in \fBbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the | | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | to place arbitrary error messages in \fBbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the specified channel. The number of references to the \fBmsg\fR value goes up by one. Previously stored information will be discarded, by releasing the reference held by the channel. The channel reference must not be NULL. .PP \fBTcl_SetChannelErrorInterp\fR stores error information in the bypass area of the specified interpreter. The number of references to the \fBmsg\fR value goes up by one. Previously stored information will be discarded, by releasing the reference held by the interpreter. The interpreter reference must not be NULL. .PP \fBTcl_GetChannelError\fR places either the error message held in the bypass area of the specified channel into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the channel is now held by the caller of the function and it is its responsibility to release that reference when it is done with the value. .PP \fBTcl_GetChannelErrorInterp\fR places either the error message held in the bypass area of the specified interpreter into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the interpreter is now held by the caller of the function and it is its responsibility to release that reference when it is done with the value. .PP Which functions of a channel driver are allowed to use which bypass function is listed below, as is which functions of the public channel API may leave a messages in the bypass areas. .IP \fBTcl_DriverCloseProc\fR May use \fBTcl_SetChannelErrorInterp\fR, and only this function. .IP \fBTcl_DriverInputProc\fR |
| ︙ | ︙ |
Changes to doc/SetResult.3.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in Tcl value to become result for \fIinterp\fR. .AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. .AP "const char" *element in String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in |
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | information as well. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. | | | | | | | | | | | | | | | | | | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | information as well. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. The interpreter result may be either a Tcl value or a string. For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR set the interpreter result to, respectively, a value and a string. Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR return the interpreter result as a value and as a string. The procedures always keep the string and value forms of the interpreter result consistent. For example, if \fBTcl_SetObjResult\fR is called to set the result to a value, then \fBTcl_GetStringResult\fR is called, it will return the value's string representation. .PP \fBTcl_SetObjResult\fR arranges for \fIobjPtr\fR to be the result for \fIinterp\fR, replacing any existing result. The result is left pointing to the value referenced by \fIobjPtr\fR. \fIobjPtr\fR's reference count is incremented since there is now a new reference to it from \fIinterp\fR. The reference count for any old result value is decremented and the old result value is freed if no references to it remain. .PP \fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value. The value's reference count is not incremented; if the caller needs to retain a long-term pointer to the value they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR arranges for \fIresult\fR to be the result for the current Tcl command in \fIinterp\fR, replacing any existing result. The \fIfreeProc\fR argument specifies how to manage the storage for the \fIresult\fR argument; it is discussed in the section \fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to an empty string. .PP \fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. If the result was set to a value by a \fBTcl_SetObjResult\fR call, the value form will be converted to a string and returned. If the value's string representation contains null bytes, this conversion will lose information. For this reason, programmers are encouraged to write their code to use the new value API procedures and to call \fBTcl_GetObjResult\fR instead. .PP \fBTcl_ResetResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. If the result is a value, its reference count is decremented and the result is left pointing to an unshared value representing an empty string. If the result is a dynamically allocated string, its memory is free*d and the result is left as a empty string. \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. .PP \fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. |
| ︙ | ︙ | |||
163 164 165 166 167 168 169 | .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR | | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR that manipulate the result as a value can be significantly more efficient. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR argument and it appends that argument to the current result as a proper Tcl list element. |
| ︙ | ︙ | |||
248 249 250 251 252 253 254 | .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS | | | 248 249 250 251 252 253 254 255 | .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS append, command, element, list, value, result, return value, interpreter |
Changes to doc/SetVar.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in Points to a Tcl value containing the new value for the variable. .AP int flags in OR-ed combination of bits providing additional information. See below for valid values. .AP "const char" *varName in Name of variable. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array. .AP "const char" *newValue in New value for variable, specified as a null-terminated string. A copy of this value is stored in the variable. .AP Tcl_Obj *part1Ptr in Points to a Tcl value containing the variable's name. The name may include a series of \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array variable. .AP Tcl_Obj *part2Ptr in If non-NULL, points to a value containing the name of an element within an array and \fIpart1Ptr\fR must refer to an array variable. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, read, and delete Tcl variables from C code. |
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS | | | 242 243 244 245 246 247 248 249 | If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS array, get variable, interpreter, scalar, set, unset, value, variable |
Changes to doc/SplitPath.3.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP These procedures have been superseded by the Tcl-value-aware procedures in the \fBFileSystem\fR man page, which are more efficient. .PP These procedures may be used to disassemble and reassemble file paths in a platform independent manner: they provide C-level access to the same functionality as the \fBfile split\fR, \fBfile join\fR, and \fBfile pathtype\fR commands. .PP |
| ︙ | ︙ |
Changes to doc/StringObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 | .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\e700\e600\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) .AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. .AP int numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. If negative, all characters up to the first null character are used. .AP int index in The index of the Unicode character to return. .AP int first in The index of the first Unicode character in the Unicode range to be returned as a new value. .AP int last in The index of the last Unicode character in the Unicode range to be returned as a new value. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP int limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." is used. .AP "const char" *format in Format control string including % conversion specifiers. .AP int objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE .SH DESCRIPTION .PP The procedures described in this manual entry allow Tcl values to be manipulated as string values. They use the internal representation of the value to store additional information to make the string manipulations more efficient. In particular, they make a series of append operations efficient by allocating extra storage space for the string so that it does not have to be copied for each append. Also, indexing and length computations are optimized because the Unicode string representation is calculated and cached as needed. When using the \fBTcl_Append*\fR family of functions where the interpreter's result is the value being appended to, it is important to call Tcl_ResetResult first to ensure you are not unintentionally appending to existing data in the result value. .PP \fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new value or modify an existing value to hold a copy of the string given by \fIbytes\fR and \fIlength\fR. \fBTcl_NewUnicodeObj\fR and \fBTcl_SetUnicodeObj\fR create a new value or modify an existing value to hold a copy of the Unicode string given by \fIunicode\fR and \fInumChars\fR. \fBTcl_NewStringObj\fR and \fBTcl_NewUnicodeObj\fR return a pointer to a newly created value with reference count zero. All four procedures set the value to hold a copy of the specified string. \fBTcl_SetStringObj\fR and \fBTcl_SetUnicodeObj\fR free any old string representation as well as any old internal representation of the value. .PP \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return a value's string representation. This is given by the returned byte pointer and (for \fBTcl_GetStringFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. If the value's UTF string representation is invalid (its byte pointer is NULL), the string representation is regenerated from the value's internal representation. The storage referenced by the returned byte pointer is owned by the value manager. It is passed back as a writable pointer so that extension author creating their own \fBTcl_ObjType\fR will be able to modify the string representation within the \fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any in-place modification of the string representation. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP \fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return a value's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated from the value's string representation. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. .PP \fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and \fIlength\fR to the string representation of the value specified by \fIobjPtr\fR. If the value has an invalid string representation, then an attempt is made to convert \fIbytes\fR is to the Unicode format. If the conversion is successful, then the converted form of \fIbytes\fR is appended to the value's Unicode representation. Otherwise, the value's Unicode representation is invalidated and converted to the UTF format, and \fIbytes\fR is appended to the value's new string representation. .PP \fBTcl_AppendUnicodeToObj\fR appends the Unicode string given by \fIunicode\fR and \fInumChars\fR to the value specified by \fIobjPtr\fR. If the value has an invalid Unicode representation, then \fIunicode\fR is converted to the UTF format and appended to the value's string representation. Appends are optimized to handle repeated appends relatively efficiently (it over-allocates the string or Unicode space to avoid repeated reallocations and copies of value's string value). .PP \fBTcl_AppendObjToObj\fR is similar to \fBTcl_AppendToObj\fR, but it appends the string or Unicode value (whichever exists and is best suited to be appended to \fIobjPtr\fR) of \fIappendObjPtr\fR to \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR | | | | | | | | | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR argument is greater than the space allocated for the value's string, then the string space is reallocated and the old value is copied to the new space; the bytes between the old length of the string and the new length may have arbitrary values. If the \fInewLength\fR argument is less than the current length of the value's string, with \fIobjPtr->length\fR is reduced without reallocating the string space; the original allocated size for the string is recorded in the value, so that the string length can be enlarged in a subsequent call to \fBTcl_SetObjLength\fR without reallocating storage. In all cases \fBTcl_SetObjLength\fR leaves a null character at \fIobjPtr->bytes[newLength]\fR. .PP \fBTcl_AttemptSetObjLength\fR is identical in function to \fBTcl_SetObjLength\fR except that if sufficient memory to satisfy the request cannot be allocated, it does not cause the Tcl interpreter to \fBpanic\fR. Thus, if \fInewLength\fR is greater than the space allocated for the value's string, and there is not enough memory available to satisfy the request, \fBTcl_AttemptSetObjLength\fR will take no action and return 0 to indicate failure. If there is enough memory to satisfy the request, \fBTcl_AttemptSetObjLength\fR behaves just like \fBTcl_SetObjLength\fR and returns 1 to indicate success. .PP The \fBTcl_ConcatObj\fR function returns a new string value whose value is the space-separated concatenation of the string representations of all of the values in the \fIobjv\fR array. \fBTcl_ConcatObj\fR eliminates leading and trailing white space as it copies the string representations of the \fIobjv\fR array to the result. If an element of the \fIobjv\fR array consists of nothing but white space, then that value is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. .SH "SEE ALSO" Tcl_NewObj(3), Tcl_IncrRefCount(3), Tcl_DecrRefCount(3), format(n), sprintf(3) .SH KEYWORDS append, internal representation, value, value type, string value, string type, string representation, concat, concatenate, unicode |
Changes to doc/SubstObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" 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_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" 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_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SubstObj \- perform substitutions on Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_SubstObj\fR(\fIinterp, objPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute Tcl scripts and lookup variables. If an error occurs, the interpreter's result is modified to hold an error message. .AP Tcl_Obj *objPtr in A Tcl value containing the string to perform substitutions on. .AP int flags in ORed combination of flag bits that specify which substitutions to perform. The flags \fBTCL_SUBST_COMMANDS\fR, \fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are currently supported, and \fBTCL_SUBST_ALL\fR is provided as a convenience for the common case where all substitutions are desired. .BE .SH DESCRIPTION .PP The \fBTcl_SubstObj\fR function is used to perform substitutions on strings in the fashion of the \fBsubst\fR command. It gets the value of the string contained in \fIobjPtr\fR and scans it, copying characters and performing the chosen substitutions as it goes to an output value which is returned as the result of the function. In the event of an error occurring during the execution of a command or variable substitution, the function returns NULL and an error message is left in \fIinterp\fR's result. .PP Three kinds of substitutions are supported. When the \fBTCL_SUBST_BACKSLASHES\fR bit is set in \fIflags\fR, sequences that look like backslash substitutions for Tcl commands are replaced by |
| ︙ | ︙ |
Changes to doc/TCL_MEM_DEBUG.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | \fI\-\-enable\-symbols=mem\fR flag to the \fIconfigure\fR script when building). This will also compile in a non-stub version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl. .PP \fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined for all modules that are going to be linked together. If they are not, link errors will occur, with either \fBTcl_DbCkfree\fR and \fBTcl_DbCkalloc\fR or | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | \fI\-\-enable\-symbols=mem\fR flag to the \fIconfigure\fR script when building). This will also compile in a non-stub version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl. .PP \fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined for all modules that are going to be linked together. If they are not, link errors will occur, with either \fBTcl_DbCkfree\fR and \fBTcl_DbCkalloc\fR or \fBTcl_Alloc\fR and \fBTcl_Free\fR being undefined. .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP |
| ︙ | ︙ |
Changes to doc/TclZlib.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 52 53 | \fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) .sp int \fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) .fi .SH ARGUMENTS | > > | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | \fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) .sp int \fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) .sp \fBTcl_ZlibStreamSetCompressionDictionary\fR(\fIzshandle, compDict\fR) .fi .SH ARGUMENTS .AS Tcl_ZlibStream zshandle in .AP Tcl_Interp *interp in The interpreter to store resulting compressed or uncompressed data in. Also where any error messages are written. For \fBTcl_ZlibStreamInit\fR, this can be NULL to create a stream that is not bound to a command. .AP int format in What format of compressed data to work with. Must be one of \fBTCL_ZLIB_FORMAT_ZLIB\fR for zlib-format data, \fBTCL_ZLIB_FORMAT_GZIP\fR for gzip-format data, or \fBTCL_ZLIB_FORMAT_RAW\fR for raw compressed data. In addition, for decompression only, \fBTCL_ZLIB_FORMAT_AUTO\fR may also be chosen which can automatically detect whether the compressed data was in zlib or gzip format. .AP Tcl_Obj *dataObj in/out A byte-array value containing the data to be compressed or decompressed, or to which the data extracted from the stream is appended when passed to \fBTcl_ZlibStreamGet\fR. .AP int level in What level of compression to use. Should be a number from 0 to 9 or one of the following: \fBTCL_ZLIB_COMPRESS_NONE\fR for no compression, \fBTCL_ZLIB_COMPRESS_FAST\fR for fast but inefficient compression, \fBTCL_ZLIB_COMPRESS_BEST\fR for slow but maximal compression, or |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib library by Jean-loup Gailly and Mark Adler. .PP \fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and decompress the data contained in the \fIdataObj\fR argument, according to the \fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in the \fIdictObj\fR parameter is used to convey additional header information about the compressed data when the compression format supports it; currently, the dictionary is only used when the \fIformat\fR parameter is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section below. Upon success, both functions leave the resulting compressed or | > > > > > > > | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to indicate whether a compression dictionary was present other than to fail on decompression. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib library by Jean-loup Gailly and Mark Adler. .PP \fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and decompress the data contained in the \fIdataObj\fR argument, according to the \fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in the \fIdictObj\fR parameter is used to convey additional header information about the compressed data when the compression format supports it; currently, the dictionary is only used when the \fIformat\fR parameter is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section below. Upon success, both functions leave the resulting compressed or decompressed data in a byte-array value that is the Tcl interpreter's result; the returned value is a standard Tcl result code. .PP \fBTcl_ZlibAdler32\fR and \fBTcl_ZlibCRC32\fR compute checksums on arrays of bytes, returning the computed checksum. Checksums are computed incrementally, allowing data to be processed one block at a time, but this requires the caller to maintain the current checksum and pass it in as the \fIinitValue\fR parameter; the initial value to use for this can be obtained by using NULL for |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | to be thread-safe; each stream should only ever be used from the thread that created it. When working with gzip streams, a dictionary (fields as given in the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the \fIdictObj\fR parameter that on compression allows control over the generated headers, and on decompression allows discovery of the existing headers. Note that the dictionary will be written to on decompression once sufficient data has been read to have a complete header. This means that the dictionary must | | | | > > > > > > > > > > > > > > > > > > > | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | to be thread-safe; each stream should only ever be used from the thread that created it. When working with gzip streams, a dictionary (fields as given in the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the \fIdictObj\fR parameter that on compression allows control over the generated headers, and on decompression allows discovery of the existing headers. Note that the dictionary will be written to on decompression once sufficient data has been read to have a complete header. This means that the dictionary must be an unshared value in that case; a blank value created with \fBTcl_NewObj\fR is suggested. .PP Once a stream has been constructed, \fBTcl_ZlibStreamPut\fR is used to add data to the stream and \fBTcl_ZlibStreamGet\fR is used to retrieve data from the stream after processing. Both return normal Tcl result codes and leave an error message in the result of the interpreter that the stream is registered with in the error case (if such a registration has been performed). With \fBTcl_ZlibStreamPut\fR, the data buffer value passed to it should not be modified afterwards. With \fBTcl_ZlibStreamGet\fR, the data buffer value passed to it will have the data bytes appended to it. Internally to the stream, data is kept compressed so as to minimize the cost of buffer space. .PP \fBTcl_ZlibStreamChecksum\fR returns the checksum computed over the uncompressed data according to the format, and \fBTcl_ZlibStreamEof\fR returns a boolean value indicating whether the end of the uncompressed data has been reached. .PP \fBTcl_ZlibStreamSetCompressionDictionary\fR is used to control the compression dictionary used with the stream, a compression dictionary being an array of bytes (such as might be created with \fBTcl_NewByteArrayObj\fR) that is used to initialize the compression engine rather than leaving it to create it on the fly from the data being compressed. Setting a compression dictionary allows for more efficient compression in the case where the start of the data is highly regular, but it does require both the compressor and the decompressor to agreee on the value to use. Compression dictionaries are only fully supported for zlib-format data; on compression, they must be set before any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its \fB\-errorcode\fR set to .QW "\fBZLIB NEED_DICT\fI code\fR" ; the \fIcode\fR will be the Adler-32 checksum (see \fBTcl_ZlibAdler32\fR) of the compression dictionary sought. (Note that this is only true for zlib-format streams; gzip streams ignore compression dictionaries as the format specification doesn't permit them, and raw streams just produce a data error if the compression dictionary is missing or incorrect.) .PP If you wish to clear a stream and reuse it for a new compression or decompression action, \fBTcl_ZlibStreamReset\fR will do this and return a normal Tcl result code to indicate whether it was successful; if the stream is registered with an interpreter, an error message will be left in the interpreter result when this function returns TCL_ERROR. Finally, \fBTcl_ZlibStreamClose\fR will clean up the stream and delete the associated command: using \fBTcl_DeleteCommand\fR on the stream's command is equivalent (when such a command exists). .SH "GZIP OPTIONS DICTIONARY" .PP The \fIdictObj\fR parameter to \fBTcl_ZlibDeflate\fR, \fBTcl_ZlibInflate\fR and \fBTcl_ZlibStreamInit\fR is used to pass a dictionary of options about that is used to describe the gzip header in the compressed data. When creating compressed data, the dictionary is read and when unpacking compressed data the dictionary is written (in which case the \fIdictObj\fR parameter must refer to an unshared dictionary value). .PP The following fields in the dictionary value are understood. All other fields are ignored. No field is required when creating a gzip-format stream. .TP \fBcomment\fR . This holds the comment field of the header, if present. If absent, no comment was supplied (on decompression) or will be created (on compression). .TP |
| ︙ | ︙ |
Changes to doc/WrongNumArgs.3.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. .AP int objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in Arguments to command that had the wrong number of arguments. .AP "const char" *message in Additional error information to print after leading arguments from \fIobjv\fR. This typically gives the acceptable syntax of the command. This argument may be NULL. .BE .SH DESCRIPTION .PP \fBTcl_WrongNumArgs\fR is a utility procedure that is invoked by command procedures when they discover that they have received the wrong number of arguments. \fBTcl_WrongNumArgs\fR generates a standard error message and stores it in the result value of \fIinterp\fR. The message includes the \fIobjc\fR initial elements of \fIobjv\fR plus \fImessage\fR. For example, if \fIobjv\fR consists of the values \fBfoo\fR and \fBbar\fR, \fIobjc\fR is 1, and \fImessage\fR is .QW "\fBfileName count\fR" then \fIinterp\fR's result value will be set to the following string: .PP .CS wrong # args: should be "foo fileName count" .CE .PP If \fIobjc\fR is 2, the result will be set to the following string: .PP .CS wrong # args: should be "foo bar fileName count" .CE .PP \fIObjc\fR is usually 1, but may be 2 or more for commands like \fBstring\fR and the Tk widget commands, which use the first argument as a subcommand. .PP Some of the values in the \fIobjv\fR array may be abbreviations for a subcommand. The command \fBTcl_GetIndexFromObj\fR will convert the abbreviated string value into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any \fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand name in the error message instead of the abbreviated name that was originally passed in. Using the above example, let us assume that \fIbar\fR is actually an abbreviation for \fIbarfly\fR and the value is now an \fIindexObject\fR because it was passed to \fBTcl_GetIndexFromObj\fR. In this case the error message would be: .PP .CS wrong # args: should be "foo barfly fileName count" .CE .SH "SEE ALSO" Tcl_GetIndexFromObj(3) .SH KEYWORDS command, error message, wrong number of arguments |
Changes to doc/dde.n.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the 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 | | > > | | | > > > | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the 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 . \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, \fIservice\fR is the name of an application. \fItopic\fR is application 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 . \fBdde request\fR is typically used to get the value of something; the value of a cell in Microsoft Excel or the text of a selection in Microsoft Word. \fIservice\fR is typically the name of an application, |
| ︙ | ︙ |
Changes to doc/define.n.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . .TP | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . .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 |
| ︙ | ︙ |
Changes to doc/dict.n.
| ︙ | ︙ | |||
142 143 144 145 146 147 148 149 150 151 152 153 154 155 | . This appends the given items to the list value that the given 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 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. .TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . Return a dictionary that contains the contents of each of the \fIdictionaryValue\fR arguments. Where two (or more) dictionaries contain a mapping for the same key, the resulting dictionary maps that key to the value according to the last dictionary on the command line | > > > > > > > > > > > > > > > > > > > > > > > > > | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
.
This appends the given items to the list value that the given 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 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.
.TP
\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
returning a new dictionary. It takes three arguments: the first is a
two-element list of variable names (for the key and value respectively of each
mapping in the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key and value
variables set appropriately (in the manner of \fBlmap\fR). In an iteration
where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an
\fBerror\fR, etc.) the result of the script is put into an accumulator
dictionary using the key that is the current contents of the \fIkeyVar\fR
variable at that point. The result of the \fBdict map\fR command is the
accumulator dictionary after all keys have been iterated over.
.RS
.PP
If the evaluation of the body for any particular step generates a \fBbreak\fR,
no further pairs from the dictionary will be iterated over and the \fBdict
map\fR command will terminate successfully immediately. If the evaluation of
the body for a particular step generates a \fBcontinue\fR result, the current
iteration is aborted and the accumulator dictionary is not modified. The order
of iteration is the natural order of the dictionary (typically the order in
which the keys were added to the dictionary; the order is the same as that
used in \fBdict for\fR).
.RE
.TP
\fBdict merge \fR?\fIdictionaryValue ...\fR?
.
Return a dictionary that contains the contents of each of the
\fIdictionaryValue\fR arguments. Where two (or more) dictionaries
contain a mapping for the same key, the resulting dictionary maps that
key to the value according to the last dictionary on the command line
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
.CS
set foo {foo {a b} bar 2 baz 3}
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
| | | | 429 430 431 432 433 434 435 436 437 438 439 440 441 |
.CS
set foo {foo {a b} bar 2 baz 3}
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
.SH KEYWORDS
dictionary, create, update, lookup, iterate, filter, map
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/expr.n.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | 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 additional operators not found in C. .SS OPERANDS .PP A Tcl expression consists of a combination of operands, operators, | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | 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 additional operators not found in C. .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, |
| ︙ | ︙ | |||
278 279 280 281 282 283 284 285 286 287 288 289 290 291 | .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). .PP See the \fBmathfunc\fR(n) manual page 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 | > > > > > > > > > > > > | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
.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).
.PP
Some mathematical functions have several arguments, separated by commas like in C. Thus:
.PP
.CS
\fBexpr\fR {hypot($x,$y)}
.CE
.PP
ends up as
.PP
.CS
tcl::mathfunc::hypot $x $y
.CE
.PP
See the \fBmathfunc\fR(n) manual page 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
|
| ︙ | ︙ |
Changes to doc/fconfigure.n.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input or output. \fINewvalue\fR must be between one and one million, allowing buffers of one to one million bytes in size. .TP \fB\-encoding\fR \fIname\fR . This option is used to specify the encoding of the channel, so that the data can be converted to and from Unicode for use in Tcl. For instance, in order for Tcl to read characters from a Japanese file in \fBshiftjis\fR and properly process and display the contents, the encoding would be set |
| ︙ | ︙ |
Changes to doc/fileevent.n.
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP | | | | | | > > > | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP Event-driven I/O works best for channels that have been placed into nonblocking mode with the \fBfconfigure\fR command. In blocking mode, a \fBputs\fR command may block if you give it more data than the underlying file or device can accept, and a \fBgets\fR or \fBread\fR command will block if you attempt to read more data than is ready; a readable underlying file or device may not even guarantee that a blocking [read 1] will succeed (counter-examples being multi-byte encodings, compression or encryption transforms ). In all such cases, no events will be processed while the commands block. .PP In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. See the documentation for the individual commands for information on how they handle blocking and nonblocking channels. .PP Testing for the end of file condition should be done after any attempts read the channel data. The eof flag is set once an attempt to read the end of data has occurred and testing before this read will require an |
| ︙ | ︙ |
Added doc/lmap.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
'\"
'\" Copyright (c) 2012 Trevor Davel
'\"
'\" 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 lmap n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lmap \- Iterate over all elements in one or more lists and collect results
.SH SYNOPSIS
\fBlmap \fIvarname list body\fR
.br
\fBlmap \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR
.BE
.SH DESCRIPTION
.PP
The \fBlmap\fR command implements a loop where the loop variable(s) take on
values from one or more lists, and the loop returns a list of results
collected from each iteration.
.PP
In the simplest case there is one loop variable, \fIvarname\fR, and one list,
\fIlist\fR, that is a list of values to assign to \fIvarname\fR. The
\fIbody\fR argument is a Tcl script. For each element of \fIlist\fR (in order
from first to last), \fBlmap\fR assigns the contents of the element to
\fIvarname\fR as if the \fBlindex\fR command had been used to extract the
element, then calls the Tcl interpreter to execute \fIbody\fR. If execution of
the body completes normally then the result of the body is appended to an
accumulator list. \fBlmap\fR returns the accumulator list.
.PP
In the general case there can be more than one value list (e.g., \fIlist1\fR
and \fIlist2\fR), and each value list can be associated with a list of loop
variables (e.g., \fIvarlist1\fR and \fIvarlist2\fR). During each iteration of
the loop the variables of each \fIvarlist\fR are assigned consecutive values
from the corresponding \fIlist\fR. Values in each \fIlist\fR are used in order
from first to last, and each value is used exactly once. The total number of
loop iterations is large enough to use up all the values from all the value
lists. If a value list does not contain enough elements for each of its loop
variables in each iteration, empty values are used for the missing elements.
.PP
The \fBbreak\fR and \fBcontinue\fR statements may be invoked inside
\fIbody\fR, with the same effect as in the \fBfor\fR and \fBforeach\fR
commands. In these cases the body does not complete normally and the result is
not appended to the accumulator list.
.SH EXAMPLES
.PP
Zip lists together:
.PP
.CS
set list1 {a b c d}
set list2 {1 2 3 4}
set zipped [\fBlmap\fR a $list1 b $list2 {list $a $b}]
# The value of zipped is "{a 1} {b 2} {c 3} {d 4}"
.CE
.PP
Filter a list to remove odd values:
.PP
.CS
set values {1 2 3 4 5 6 7 8}
proc isEven {n} {expr {($n % 2) == 0}}
set goodOnes [\fBlmap\fR x $values {expr {
[isEven $x] ? $x : [continue]
}}]
# The value of goodOnes is "2 4 6 8"
.CE
.PP
Take a prefix from a list based on the contents of the list:
.PP
.CS
set values {8 7 6 5 4 3 2 1}
proc isGood {counter} {expr {$n > 3}}
set prefix [\fBlmap\fR x $values {expr {
[isGood $x] ? $x : [break]
}}]
# The value of prefix is "8 7 6 5 4"
.CE
.SH "SEE ALSO"
break(n), continue(n), for(n), foreach(n), while(n)
.SH KEYWORDS
foreach, iteration, list, loop, map
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/load.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName\fR .br \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName\fR .br \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName interp\fR .BE .SH DESCRIPTION .PP This command loads binary code from a file into the application's address space and calls an initialization procedure in the package to incorporate it into an interpreter. \fIfileName\fR is the name of the file containing the code; its exact form varies |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 | The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with .QW "library not found" error, it is also possible | > > > > > > > > > > > > > > > > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .PP If \fB\-global\fR is specified preceding the filename, all symbols found in the shared library are exported for global use by other libraries. The option \fB\-lazy\fR delays the actual loading of symbols until their first actual use. The options may be abbreviated. The option \fB\-\-\fR indicates the end of the options, and should be used if you wish to use a filename which starts with \fB\-\fR and you provide a packageName to the \fBload\fR command. .PP On platforms which do not support the \fB\-global\fR or \fB\-lazy\fR options, the options still exist but have no effect. Note that use of the \fB\-global\fR or \fB\-lazy\fR option may lead to crashes in your application later (in case of symbol conflicts resp. missing symbols), which cannot be detected during the \fBload\fR. So, only use this when you know what you are doing, you will not get a nice error message when something is wrong with the loaded library. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with .QW "library not found" error, it is also possible |
| ︙ | ︙ |
Changes to doc/msgcat.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros | | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" 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 "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp \fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp \fB::msgcat::mcpreferences\fR .sp \fB::msgcat::mcload \fIdirname\fR .sp \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp .VS "TIP 404" \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcflmset \fIsrc-trans-list\fR .VE "TIP 404" .sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
| > > > > > > > > > > > > > > > > > > > > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR?
.VS "TIP 404"
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the
current namespace for the locale implied by the name of the message catalog
being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not
specified, \fIsrc-string\fR is used for both. The function returns
\fItranslate-string\fR.
.VE "TIP 404"
.TP
\fB::msgcat::mcflmset \fIsrc-trans-list\fR
.VS "TIP 404"
Sets the translation for multiple source strings in \fIsrc-trans-list\fR in
the current namespace for the locale implied by the name of the message
catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must
have an even number of elements and is in the form {\fIsrc-string
translate-string\fR ?\fIsrc-string translate-string ...\fR?}
\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations
of \fB::msgcat::mcflset\fR. The function returns the number of translations set.
.VE "TIP 404"
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP | | | > > > > | | < | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. From Windows Vista on, the RFC4747 locale name "lang-script-country-options" is transformed to the locale as "lang_country_script" (Example: sr-Latn-CS -> sr_cs_latin). For Windows XP, the language id is transformed analoguously (Example: 0c1a -> sr_yu_cyrillic). If all these attempts to discover an initial locale from the user's environment fail, msgcat defaults to an initial locale of .QW C . .PP When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user specifies en_GB_Funky, the locales |
| ︙ | ︙ | |||
279 280 281 282 283 284 285 | is called .QW \fBROOT.msg\fR . This exception is made so as not to cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. .IP [3] | | | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
is called
.QW \fBROOT.msg\fR .
This exception is made so as not to
cause peculiar behavior, such as marking the message file as
.QW hidden
on Unix file systems.
.IP [3]
The file contains a series of calls to \fBmcflset\fR and
\fBmcflmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.PP
.CS
namespace eval ::mypackage {
\fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!"
}
.CE
.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
|
| ︙ | ︙ |
Changes to doc/next.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" 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 next n 0.1 TclOO "TclOO Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" 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 next n 0.1 TclOO "TclOO Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME next, nextto \- invoke superclass method implementations .SH SYNOPSIS .nf package require TclOO \fBnext\fR ?\fIarg ...\fR? \fBnextto\fI class\fR ?\fIarg ...\fR? .fi |
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: | < < < < < < < < < < < < < < < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically less than, equal to, or greater than \fIstring2\fR. If \fB\-length\fR is specified, then only the |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 | | > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 Any Unicode whitespace character, zero width space (U+200b), word joiner (U+2060) and zero width no-break space (U+feff) (=BOM). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional |
| ︙ | ︙ | |||
194 195 196 197 198 199 200 | will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR . Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the | | | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR . Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the number of bytes used to store the string. If the value is a byte array value (such as those returned from reading a binary encoded channel), then this will return the actual byte length of the value. .TP \fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR . Replaces substrings in \fIstring\fR based on the key-value pairs in \fImapping\fR. \fImapping\fR is a list of \fIkey value key value ...\fR as in the form returned by \fBarray get\fR. Each instance of a key in the string will be replaced with its corresponding value. If |
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .SS "OBSOLETE SUBCOMMANDS" .PP These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. .TP \fBstring bytelength \fIstring\fR . Returns a decimal string giving the number of bytes used to represent \fIstring\fR in memory. Because UTF\-8 uses one to three bytes to represent Unicode characters, the byte length will not be the same as the character length in general. The cases where a script cares about the byte length are rare. .RS .PP In almost all cases, you should use the \fBstring length\fR operation (including determining the length of a Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. .PP \fICompatibility note:\fR it is likely that this subcommand will be withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. .RE .TP \fBstring wordend \fIstring charIndex\fR . Returns the index of the character just after the last one in the word containing character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be specified using the forms in \fBSTRING INDICES\fR. A word is considered to be any contiguous range of alphanumeric (Unicode letters |
| ︙ | ︙ |
Changes to doc/tclsh.1.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS \fBtclsh\fR ?\fB\-encoding \fIname\fR? ?\fIfileName arg arg ...\fR? .BE .SH DESCRIPTION .PP \fBTclsh\fR is a shell-like application that reads Tcl commands from its standard input or from a file and evaluates them. If invoked with no arguments then it runs interactively, reading Tcl commands from standard input and printing command results and |
| ︙ | ︙ |
Changes to doc/trace.n.
| ︙ | ︙ | |||
139 140 141 142 143 144 145 | course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .PP .CS | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .PP .CS \fIcommandPrefix command-string code result op\fR .CE .PP \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an arbitrary command for a \fBenterstep\fR operation), including all arguments in their fully expanded form. \fICode\fR gives the result code of that execution, and \fIresult\fR |
| ︙ | ︙ |
Changes to doc/zlib.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2008-2012 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH zlib n 8.6 Tcl "Tcl Built-In Commands" .BS |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). | > > > > > > > | | < > | | > > | | > > > > > > > > > > > > > > > > < < < < < < < < | > > > > > > > > | | | | > > > | > > > > | | > > > > > | | | | > > > > > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. Not valid for transformations that work with gzip-format data. .VE .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . The maximum number of bytes ahead to read when decompressing. This defaults to 1, which ensures that data is always decompressed correctly, but may be increased to improve performance. This is more useful when the channel is non-blocking. .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: .TP \fB\-checksum\fI checksum\fR . This read-only option gets the current checksum for the uncompressed data that the compression engine has seen so far. It is valid for both compressing and decompressing transforms, but not for the raw inflate and deflate formats. The compression algorithm depends on what format is being produced or consumed. .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" This read-write options gets or sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. It is not valid for transformations that work with gzip-format data, and should not normally be set on compressing transformations other than at the point where the transformation is stacked. .VE .TP \fB\-flush\fI type\fR . This write-only operation flushes the current state of the compressor to the underlying channel. It is only valid for compressing transformations. The \fItype\fR must be either \fBsync\fR or \fBfull\fR for a normal flush or an expensive flush respectively. Flushing degrades the compression ratio, but makes it easier for a decompressor to recover more of the file in the case of data corruption. .TP \fB\-header\fI dictionary\fR . This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the maximum number of bytes ahead to read from the underlying data source. This defaults to 1, which ensures that data is always decompressed correctly, but may be increased to improve performance. This is more useful when the channel is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes and \fIoptions\fR are supported: .RS .TP \fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, .VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). .VE .TP \fBzlib stream decompress\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. .VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use if required. .VE .TP \fBzlib stream deflate\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, .VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). Note that the raw compressed data includes no metadata about what compression dictionary was used, if any; that is a feature of the zlib-format data. .VE .TP \fBzlib stream gunzip\fR . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. .TP \fBzlib stream gzip\fR ?\fB\-header \fIheader\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces gzip-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, and the header descriptor dictionary \fIheader\fR (if specified; for keys see \fBzlib gzip\fR). .TP \fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and produces uncompressed output. .VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that there are no checks in place to determine whether the compression dictionary is correct. .VE .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP \fBzlib adler32\fI string\fR ?\fIinitValue\fR? . Compute a checksum of binary string \fIstring\fR using the Adler-32 algorithm. If given, \fIinitValue\fR is used to initialize the checksum engine. |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | command. They are used by calling their \fBput\fR subcommand one or more times to load data in, and their \fBget\fR subcommand one or more times to extract the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP | | | | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | command. They are used by calling their \fBput\fR subcommand one or more times to load data in, and their \fBget\fR subcommand one or more times to extract the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP \fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR . A short-cut for .QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" followed by .QW "\fIstream \fBget\fR" . .TP \fIstream \fBchecksum\fR . Returns the checksum of the uncompressed data seen so far by this stream. .TP |
| ︙ | ︙ | |||
314 315 316 317 318 319 320 321 |
.QW "\fIstream \fBput \-fullflush {}\fR" .
.TP
\fIstream \fBget \fR?\fIcount\fR?
.
Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the
transformation applied. If \fIcount\fR is omitted, the entire contents of the
buffers are returned.
.TP
| > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
.QW "\fIstream \fBput \-fullflush {}\fR" .
.TP
\fIstream \fBget \fR?\fIcount\fR?
.
Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the
transformation applied. If \fIcount\fR is omitted, the entire contents of the
buffers are returned.
.
\fIstream \fBheader\fR
.
Return the gzip header description dictionary extracted from the stream. Only
supported for streams created with their \fImode\fR parameter set to
\fBgunzip\fR.
.TP
\fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR
.
Append the contents of the binary string \fIdata\fR to \fIstream\fR's internal
buffers while applying the transformation. The following \fIoption\fRs are
supported (or an unambiguous prefix of them), which are used to modify the
way in which the transformation is applied:
.RS
.TP
\fB\-dictionary\fI binData\fR
.VS "TIP 400"
Sets the compression dictionary to use when working with compressing or
decompressing the data to be \fIbinData\fR.
.VE
.TP
\fB\-finalize\fR
.
Mark the stream as finished, ensuring that all bytes have been wholly
compressed or decompressed. For gzip streams, this also ensures that the
footer is written to the stream. The stream will need to be reset before
having more data written to it after this, though data can still be read out
of the stream with the \fBget\fR subcommand.
.RS
.PP
This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR
options.
.RE
.TP
\fB\-flush\fR
.
Ensure that a decompressor consuming the bytes that the current (compressing)
stream is producing will be able to produce all the bytes that have been
compressed so far, at some performance penalty.
.RS
.PP
This option is mutually exclusive with the \fB\-finalize\fR and
\fB\-fullflush\fR options.
.RE
.TP
\fB\-fullflush\fR
.
Ensure that not only can a decompressor handle all the bytes produced so far
(as with \fB\-flush\fR above) but also that it can restart from this point if
it detects that the stream is partially corrupt. This incurs a substantial
performance penalty.
.RS
.PP
This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR
options.
.RE
.RE
.TP
\fIstream \fBreset\fR
.
Puts any stream, including those that have been finalized or that have reached
eof, back into a state where it can process more data. Throws away all
internally buffered data.
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | $\fIstrm \fBfinalize\fR set compData [$\fIstrm \fBget\fR] $\fIstrm \fBclose\fR .CE .SH "SEE ALSO" binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 .SH "KEYWORDS" | | | 450 451 452 453 454 455 456 457 458 459 460 | $\fIstrm \fBfinalize\fR set compData [$\fIstrm \fBget\fR] $\fIstrm \fBclose\fR .CE .SH "SEE ALSO" binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 .SH "KEYWORDS" compress, decompress, deflate, gzip, inflate, zlib '\" Local Variables: '\" mode: nroff '\" End: |
Changes to generic/regc_locale.c.
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
/*
* Unicode: white space characters.
*/
static const crange spaceRangeTable[] = {
| | | > | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 |
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
/*
* Unicode: white space characters.
*/
static const crange spaceRangeTable[] = {
{0x9, 0xd}, {0x2000, 0x200b}
};
#define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange))
static const chr spaceCharTable[] = {
0x20, 0x85, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f,
0x2060, 0x3000, 0xfeff
};
#define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr))
/*
* Unicode: lowercase characters.
*/
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
{0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, {0x1a90, 0x1a99}, {0x1aa0, 0x1aad},
{0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37},
{0x1c3b, 0x1c49}, {0x1c4d, 0x1c7f}, {0x1cc0, 0x1cc7}, {0x1cd0, 0x1cf6},
{0x1d00, 0x1de6}, {0x1dfc, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45},
{0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4},
{0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e},
| | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 |
{0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, {0x1a90, 0x1a99}, {0x1aa0, 0x1aad},
{0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37},
{0x1c3b, 0x1c49}, {0x1c4d, 0x1c7f}, {0x1cc0, 0x1cc7}, {0x1cd0, 0x1cf6},
{0x1d00, 0x1de6}, {0x1dfc, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45},
{0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4},
{0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef},
{0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e},
{0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0},
{0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a},
{0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e},
{0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67},
{0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6},
{0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6},
{0x2dd8, 0x2dde}, {0x2de0, 0x2e3b}, {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3},
{0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, {0x3001, 0x303f}, {0x3041, 0x3096},
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
declare 628 {
void *Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle,
const char *symbol)
}
declare 629 {
int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr)
}
# ----- BASELINE -- FOR -- 8.6.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
| > > > > > > | 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 |
declare 628 {
void *Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle,
const char *symbol)
}
declare 629 {
int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr)
}
# TIP #400
declare 630 {
void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj)
}
# ----- BASELINE -- FOR -- 8.6.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | * macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl.xcode/project.pbxproj (not patchlevel) 2 LOC * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) | < < | | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | * macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl.xcode/project.pbxproj (not patchlevel) 2 LOC * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE #define TCL_RELEASE_SERIAL 0 #define TCL_VERSION "8.6" #define TCL_PATCH_LEVEL "8.6.0" /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. * We use this method because there is no autoconf equivalent. */ |
| ︙ | ︙ | |||
496 497 498 499 500 501 502 | * "real" definition in tclInt.h. * * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ | | > > | | | > > | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
* "real" definition in tclInt.h.
*
* Note: Tcl_ObjCmdProc functions do not directly set result and freeProc.
* Instead, they set a Tcl_Obj member in the "real" structure that can be
* accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
*/
typedef struct Tcl_Interp
#ifndef TCL_NO_DEPRECATED
{
/* TIP #330: Strongly discourage extensions from using the string
* result. */
#ifdef USE_INTERP_RESULT
char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
/* If the last command returned a string
* result, this points to it. */
void (*freeProc) (char *blockPtr)
TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
/* Zero means the string result is statically
* allocated. TCL_DYNAMIC means it was
* allocated with ckalloc and should be freed
* with ckfree. Other values give the address
* of function to invoke to free the result.
* Tcl_Eval must free it before executing next
* command. */
#else
char *resultDontUse; /* Don't use in extensions! */
void (*freeProcDontUse) (char *); /* Don't use in extensions! */
#endif
#ifdef USE_INTERP_ERRORLINE
int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine");
/* When TCL_ERROR is returned, this gives the
* line number within the command where the
* error occurred (1 if first line). */
#else
int errorLineDontUse; /* Don't use in extensions! */
#endif
}
#endif /* TCL_NO_DEPRECATED */
Tcl_Interp;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
typedef struct Tcl_Dict_ *Tcl_Dict;
|
| ︙ | ︙ | |||
848 849 850 851 852 853 854 | } 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 | | < < < | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 | } 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); /* |
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 | */ #define TCL_ZLIB_NO_FLUSH 0 #define TCL_ZLIB_FLUSH 2 #define TCL_ZLIB_FULLFLUSH 3 #define TCL_ZLIB_FINALIZE 4 /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, int result); | > > > > > > > > | 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 | */ #define TCL_ZLIB_NO_FLUSH 0 #define TCL_ZLIB_FLUSH 2 #define TCL_ZLIB_FULLFLUSH 3 #define TCL_ZLIB_FINALIZE 4 /* *---------------------------------------------------------------------------- * Definitions needed for the Tcl_LoadFile function. [TIP #416] */ #define TCL_LOAD_GLOBAL 1 #define TCL_LOAD_LAZY 2 /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, int result); |
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* http://c2.com/cgi/wiki?TrivialDoWhileLoop
*/
# define Tcl_DecrRefCount(objPtr) \
| > > | > > > | 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 |
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* http://c2.com/cgi/wiki?TrivialDoWhileLoop
*/
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
if (--(_objPtr)->refCount <= 0) { \
TclFreeObj(_objPtr); \
} \
} while(0)
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
/*
* Macros and definitions that help to debug the use of Tcl objects. When
* TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call
|
| ︙ | ︙ | |||
2586 2587 2588 2589 2590 2591 2592 | /* *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ #ifndef TCL_NO_DEPRECATED | < < < < < < < | 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 | /* *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ #ifndef TCL_NO_DEPRECATED /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. */ # define Tcl_Ckalloc Tcl_Alloc # define Tcl_Ckfree Tcl_Free |
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
261 262 263 264 265 266 267 | static int CheckOneByte(Tcl_Interp*, int); static int CheckSignedOneByte(Tcl_Interp*, int); static int CheckStack(AssemblyEnv*); static int CheckStrictlyPositive(Tcl_Interp*, int); static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, | | | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 | static int CheckOneByte(Tcl_Interp*, int); static int CheckSignedOneByte(Tcl_Interp*, int); static int CheckStack(AssemblyEnv*); static int CheckStrictlyPositive(Tcl_Interp*, int); static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr); 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); |
| ︙ | ︙ | |||
346 347 348 349 350 351 352 | #define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ /* * Source instructions recognized in the Tcl Assembly Language (TAL) */ | | > > > > > > > | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
static const TalInstDesc TalInstructionTable[] = {
/* PUSH must be first, see the code near the end of TclAssembleCode */
{"push", ASSEM_PUSH, (INST_PUSH1<<8
| INST_PUSH4), 0, 1},
{"add", ASSEM_1BYTE, INST_ADD, 2, 1},
{"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8
| INST_APPEND_SCALAR4),1, 1},
{"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8
| INST_APPEND_ARRAY4), 2, 1},
{"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1},
{"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1},
{"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1},
{"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1},
{"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0},
{"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0},
{"beginCatch", ASSEM_BEGIN_CATCH,
INST_BEGIN_CATCH4, 0, 0},
{"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1},
{"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1},
{"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1},
{"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1},
{"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1},
{"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
{"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"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},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
{"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0},
{"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0},
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
{"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1},
{"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1},
{"incrImm", ASSEM_LVT1_SINT1,
INST_INCR_SCALAR1_IMM, 0, 1},
{"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
{"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
1, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
| INST_INVOKE_STK4), INT_MIN,1},
{"jump", ASSEM_JUMP, INST_JUMP1, 0, 0},
{"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0},
{"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0},
{"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0},
{"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0},
| > > | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
{"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1},
{"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1},
{"incrImm", ASSEM_LVT1_SINT1,
INST_INCR_SCALAR1_IMM, 0, 1},
{"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
{"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
1, 1},
{"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1},
{"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
| INST_INVOKE_STK4), INT_MIN,1},
{"jump", ASSEM_JUMP, INST_JUMP1, 0, 0},
{"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0},
{"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0},
{"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0},
{"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0},
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
{"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1},
{"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS,
0, 1},
{"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1},
{"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1},
{"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0},
{"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1},
{"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8
| INST_STORE_SCALAR4), 1, 1},
{"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8
| INST_STORE_ARRAY4), 2, 1},
{"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1},
{"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
{"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0},
{"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0},
{"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0},
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
{NULL, 0, 0, 0, 0}
};
/*
* List of instructions that cannot throw an exception under any
* circumstances. These instructions are the ones that are permissible after
* an exception is caught but before the corresponding exception range is
* popped from the stack.
* The instructions must be in ascending order by numeric operation code.
*/
static const unsigned char NonThrowingByteCodes[] = {
INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */
INST_JUMP1, INST_JUMP4, /* 34-35 */
INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
| > > > > > > > > > > > | > > > > > > | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
{"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1},
{"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS,
0, 1},
{"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1},
{"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1},
{"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1},
{"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0},
{"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1},
{"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8
| INST_STORE_SCALAR4), 1, 1},
{"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8
| INST_STORE_ARRAY4), 2, 1},
{"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1},
{"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 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},
{"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1},
{"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
{"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1},
{"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
{"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1},
{"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
{"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0},
{"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0},
{"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0},
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"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}
};
/*
* List of instructions that cannot throw an exception under any
* circumstances. These instructions are the ones that are permissible after
* an exception is caught but before the corresponding exception range is
* popped from the stack.
* The instructions must be in ascending order by numeric operation code.
*/
static const unsigned char NonThrowingByteCodes[] = {
INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */
INST_JUMP1, INST_JUMP4, /* 34-35 */
INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
INST_NOP, /* 132 */
INST_STR_MAP, /* 143 */
INST_STR_FIND, /* 144 */
INST_COROUTINE_NAME, /* 149 */
INST_NS_CURRENT, /* 151 */
INST_INFO_LEVEL_NUM, /* 152 */
INST_RESOLVE_COMMAND /* 154 */
};
/*
* Helper macros.
*/
#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2
|
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 |
*-----------------------------------------------------------------------------
*/
static void
CompileEmbeddedScript(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token* tokenPtr, /* Tcl_Token containing the script */
| | | 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
*-----------------------------------------------------------------------------
*/
static void
CompileEmbeddedScript(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token* tokenPtr, /* Tcl_Token containing the script */
const TalInstDesc* instPtr) /* Instruction that determines whether
* the script is 'expr' or 'eval' */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); | < > | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); static Tcl_NRPostProc NRRunObjProc; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, |
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; | < < < | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; /* * Magical counts for the number of arguments accepted by a coroutine command * after particular kinds of [yield]. |
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1},
{"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1},
{"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
| | > | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1},
{"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1},
{"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
{"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1},
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1},
{"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1},
{"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1},
{"join", Tcl_JoinObjCmd, NULL, NULL, 1},
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1},
{"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1},
{"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1},
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, 1},
{"package", Tcl_PackageObjCmd, NULL, NULL, 1},
{"proc", Tcl_ProcObjCmd, NULL, NULL, 1},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1},
{"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1},
{"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
{"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
{"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
{"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1},
{"split", Tcl_SplitObjCmd, NULL, NULL, 1},
{"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1},
{"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1},
{"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1},
{"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1},
{"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
{"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1},
{"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1},
{"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
{"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1},
{"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1},
{"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
*/
{"after", Tcl_AfterObjCmd, NULL, NULL, 1},
|
| ︙ | ︙ | |||
1702 1703 1704 1705 1706 1707 1708 |
*
* But as we currently limit ourselves to the global namespace only for
* the source, in order to avoid potential confusion, lets prevent "::" in
* the token too. - dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
| | | | 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
*
* But as we currently limit ourselves to the global namespace only for
* the source, in order to avoid potential confusion, lets prevent "::" in
* the token too. - dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use namespace qualifiers in hidden command"
" token (rename)", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
return TCL_ERROR;
}
/*
* Find the command to hide. An error is returned if cmdName can't be
* found. Look up the command only from the global namespace. Full path of
|
| ︙ | ︙ | |||
1727 1728 1729 1730 1731 1732 1733 |
cmdPtr = (Command *) cmd;
/*
* Check that the command is really in global namespace
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
| | | > | 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 |
cmdPtr = (Command *) cmd;
/*
* Check that the command is really in global namespace
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only hide global namespace commands (use rename then hide)",
-1));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
/*
* Initialize the hidden command table if necessary.
*/
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
* It is an error to move an exposed command to a hidden command with
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
if (!isNew) {
| | | > | 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 |
* It is an error to move an exposed command to a hidden command with
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"hidden command named \"%s\" already exists",
hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
return TCL_ERROR;
}
/*
* NB: This code is currently 'like' a rename to a specialy set apart name
* table. Changes here and in TclRenameCommand must be kept in synch until
|
| ︙ | ︙ | |||
1855 1856 1857 1858 1859 1860 1861 |
/*
* Check that we have a regular name for the command (that the user is not
* trying to do an expose and a rename (to another namespace) at the same
* time).
*/
if (strstr(cmdName, "::") != NULL) {
| | | > | | | | | | | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 |
/*
* Check that we have a regular name for the command (that the user is not
* trying to do an expose and a rename (to another namespace) at the same
* time).
*/
if (strstr(cmdName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot expose to a namespace (use expose to toplevel, then rename)",
-1));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL);
return TCL_ERROR;
}
/*
* Get the command from the hidden command table:
*/
hPtr = NULL;
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr != NULL) {
hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
}
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* Check that we have a true global namespace command (enforced by
* Tcl_HideCommand but let's double check. (If it was not, we would not
* really know how to handle it).
*/
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
/*
* This case is theoritically impossible, we might rather Tcl_Panic
* than 'nicely' erroring out ?
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"trying to expose a non-global command namespace command",
-1));
return TCL_ERROR;
}
/*
* This is the global table.
*/
nsPtr = cmdPtr->nsPtr;
/*
* It is an error to overwrite an existing exposed command as a result of
* exposing a previously hidden command.
*/
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"exposed command \"%s\" already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
return TCL_ERROR;
}
/*
* Command resolvers (per-interp, per-namespace) might have resolved to a
* command for the given namespace scope with this command not being
|
| ︙ | ︙ | |||
2491 2492 2493 2494 2495 2496 2497 |
* Find the existing command. An error is returned if cmdName can't be
* found.
*/
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
| | > | | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 |
* Find the existing command. An error is returned if cmdName can't be
* found.
*/
cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't %s \"%s\": command doesn't exist",
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
oldName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
cmdNsPtr = cmdPtr->nsPtr;
oldFullName = Tcl_NewObj();
Tcl_IncrRefCount(oldFullName);
Tcl_GetCommandFullName(interp, cmd, oldFullName);
|
| ︙ | ︙ | |||
2523 2524 2525 2526 2527 2528 2529 |
* create the containing namespaces just like Tcl_CreateCommand would.
*/
TclGetNamespaceForQualName(interp, newName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
| | | | | | 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 |
* create the containing namespaces just like Tcl_CreateCommand would.
*/
TclGetNamespaceForQualName(interp, newName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
if ((newNsPtr == NULL) || (newTail == NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't rename to \"%s\": bad command name", newName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't rename to \"%s\": command already exists", newName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
"TARGET_EXISTS", NULL);
result = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 |
* function to get the namespace from which the old command is being
* renamed!
*/
Tcl_DStringInit(&newFullName);
Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
if (newNsPtr != iPtr->globalNsPtr) {
| | | 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 |
* function to get the namespace from which the old command is being
* renamed!
*/
Tcl_DStringInit(&newFullName);
Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
if (newNsPtr != iPtr->globalNsPtr) {
TclDStringAppendLiteral(&newFullName, "::");
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
|
| ︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 |
data->proc = proc;
data->numArgs = numArgs;
data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType));
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
data->clientData = clientData;
Tcl_DStringInit(&bigName);
| | | 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 |
data->proc = proc;
data->numArgs = numArgs;
data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType));
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
data->clientData = clientData;
Tcl_DStringInit(&bigName);
TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::");
Tcl_DStringAppend(&bigName, name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName),
OldMathFuncProc, data, OldMathFuncDeleteProc);
Tcl_DStringFree(&bigName);
}
|
| ︙ | ︙ | |||
3532 3533 3534 3535 3536 3537 3538 |
}
#endif
if (result != TCL_OK) {
/*
* We have a non-numeric argument.
*/
| | | | 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 |
}
#endif
if (result != TCL_OK) {
/*
* We have a non-numeric argument.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
/*
* Copy the object's numeric value to the argument record, converting
|
| ︙ | ︙ | |||
3747 3748 3749 3750 3751 3752 3753 |
*/
Tcl_Obj *
Tcl_ListMathFuncs(
Tcl_Interp *interp,
const char *pattern)
{
| | < < < < | | < < < < < | | < < < | > | < | < < > | < < < < < | | > > | > | > > | | 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 |
*/
Tcl_Obj *
Tcl_ListMathFuncs(
Tcl_Interp *interp,
const char *pattern)
{
Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1);
Tcl_Obj *result;
Tcl_InterpState state;
if (pattern) {
Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1);
Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj);
Tcl_AppendObjToObj(script, arg);
Tcl_DecrRefCount(arg); /* Should tear down patternObj too */
}
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_IncrRefCount(script);
if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
} else {
result = Tcl_NewObj();
}
Tcl_DecrRefCount(script);
Tcl_RestoreInterpState(interp, state);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclInterpReady --
|
| ︙ | ︙ | |||
3821 3822 3823 3824 3825 3826 3827 |
Tcl_ResetResult(interp);
/*
* If the interpreter has been deleted, return an error.
*/
if (iPtr->flags & DELETED) {
| < | | | 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 |
Tcl_ResetResult(interp);
/*
* If the interpreter has been deleted, return an error.
*/
if (iPtr->flags & DELETED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to call eval in deleted interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
"attempt to call eval in deleted interpreter", NULL);
return TCL_ERROR;
}
if (iPtr->execEnvPtr->rewind) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
3851 3852 3853 3854 3855 3856 3857 |
* probably because of an infinite loop somewhere.
*/
if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
| | | | 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 |
* probably because of an infinite loop somewhere.
*/
if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"too many nested evaluations (infinite loop?)", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3986 3987 3988 3989 3990 3991 3992 |
} else {
id = "ICANCEL";
if (length == 0) {
message = "eval canceled";
}
}
| | < | 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 |
} else {
id = "ICANCEL";
if (length == 0) {
message = "eval canceled";
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
}
/*
* Return TCL_ERROR to the caller (not necessarily just the Tcl core
* itself) that indicates further processing of the script or command in
* progress should halt gracefully and as soon as possible.
|
| ︙ | ︙ | |||
4167 4168 4169 4170 4171 4172 4173 |
* here, otherwise the pointer to the
* requested Command struct to be invoked. */
{
Interp *iPtr = (Interp *) interp;
int result;
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Command **cmdPtrPtr;
| > | | | | | > | < > > | 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 |
* here, otherwise the pointer to the
* requested Command struct to be invoked. */
{
Interp *iPtr = (Interp *) interp;
int result;
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Command **cmdPtrPtr;
NRE_callback *callbackPtr;
iPtr->lookupNsPtr = NULL;
/*
* Push a callback with cleanup tasks for commands; the cmdPtr at data[0]
* will be filled later when the command is found: save its address at
* objProcPtr.
*
* data[1] stores a marker for use by tailcalls; it will be set to 1 by
* command redirectors (imports, alias, ensembles) so that tailcalls
* finishes the source command and not just the target.
*/
if (iPtr->deferredCallbacks) {
callbackPtr = iPtr->deferredCallbacks;
iPtr->deferredCallbacks = NULL;
} else {
TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
callbackPtr = TOP_CB(interp);
}
cmdPtrPtr = (Command **) &(callbackPtr->data[0]);
callbackPtr->data[2] = INT2PTR(objc);
callbackPtr->data[3] = (ClientData) objv;
iPtr->numLevels++;
result = TclInterpReady(interp);
if ((result != TCL_OK) || (objc == 0)) {
return result;
}
|
| ︙ | ︙ | |||
4315 4316 4317 4318 4319 4320 4321 |
INT2PTR(objc), (ClientData) objv, NULL);
return TCL_OK;
} else {
return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
}
}
| < < < < < < < < | 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 |
INT2PTR(objc), (ClientData) objv, NULL);
return TCL_OK;
} else {
return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
}
}
int
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
|
| ︙ | ︙ | |||
4359 4360 4361 4362 4363 4364 4365 |
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
}
return result;
}
| | > > > > > > > > | 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 |
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
}
return result;
}
static int
NRCommand(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = data[0];
/* int cmdStart = PTR2INT(data[1]); NOT USED HERE */
if (cmdPtr) {
TclCleanupCommandMacro(cmdPtr);
}
((Interp *)interp)->numLevels--;
/*
* If there is a tailcall, schedule it
*/
if (data[1] && (data[1] != INT2PTR(1))) {
TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
}
/* OPT ??
* Do not interrupt a series of cleanups with async or limit checks:
* just check at the end?
*/
if (TclAsyncReady(iPtr)) {
|
| ︙ | ︙ | |||
4610 4611 4612 4613 4614 4615 4616 |
*
* In this case we worry a bit less about recursion for now, and call the
* "blocking" interface.
*/
cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
if (cmdPtr == NULL) {
| | | > | < | 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 |
*
* In this case we worry a bit less about recursion for now, and call the
* "blocking" interface.
*/
cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr);
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[0]), NULL);
/*
* Release any resources we locked and allocated during the handler
* call.
*/
for (i = 0; i < handlerObjc; ++i) {
Tcl_DecrRefCount(newObjv[i]);
}
TclStackFree(interp, newObjv);
return TCL_ERROR;
}
if (lookupNsPtr) {
savedNsPtr = varFramePtr->nsPtr;
varFramePtr->nsPtr = lookupNsPtr;
}
TclSkipTailcall(interp);
TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
newObjv, savedNsPtr, NULL);
return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}
static int
TEOV_NotFoundCallback(
ClientData data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
5855 5856 5857 5858 5859 5860 5861 | * * Side effects: * See the functions they call. * *---------------------------------------------------------------------- */ | < < | 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 |
*
* Side effects:
* See the functions they call.
*
*----------------------------------------------------------------------
*/
int
Tcl_EvalObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
return Tcl_EvalObjEx(interp, objPtr, 0);
}
int
Tcl_GlobalEvalObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
|
| ︙ | ︙ | |||
6018 6019 6020 6021 6022 6023 6024 | eoFramePtr->cmd.listPtr = listPtr; eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; } | > | | 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 |
eoFramePtr->cmd.listPtr = listPtr;
eoFramePtr->data.eval.path = NULL;
iPtr->cmdFramePtr = eoFramePtr;
}
TclMarkTailcall(interp);
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
NULL, NULL);
ListObjGetElements(listPtr, objc, objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
if (!(flags & TCL_EVAL_DIRECT)) {
|
| ︙ | ︙ | |||
6279 6280 6281 6282 6283 6284 6285 |
* result code was returned. */
int returnCode) /* The unexpected result code. */
{
char buf[TCL_INTEGER_SPACE];
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
| | | | | | 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 |
* result code was returned. */
int returnCode) /* The unexpected result code. */
{
char buf[TCL_INTEGER_SPACE];
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invoked \"break\" outside of a loop", -1));
} else if (returnCode == TCL_CONTINUE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invoked \"continue\" outside of a loop", -1));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"command returned bad code: %d", returnCode));
}
sprintf(buf, "%d", returnCode);
Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL);
}
|
| ︙ | ︙ | |||
6618 6619 6620 6621 6622 6623 6624 |
int result;
if (interp == NULL) {
return TCL_ERROR;
}
if ((objc < 1) || (objv == NULL)) {
| > | > | < | 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 |
int result;
if (interp == NULL) {
return TCL_ERROR;
}
if ((objc < 1) || (objv == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal argument vector", -1));
return TCL_ERROR;
}
if ((flags & TCL_INVOKE_HIDDEN) == 0) {
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = Tcl_GetHashValue(hPtr);
/*
|
| ︙ | ︙ | |||
7263 7264 7265 7266 7267 7268 7269 |
mp_sqrt(&big, &root);
mp_clear(&big);
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
negarg:
| > | | 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 |
mp_sqrt(&big, &root);
mp_clear(&big);
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
negarg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"square root of negative argument", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
|
| ︙ | ︙ | |||
8273 8274 8275 8276 8277 8278 8279 | * implementation does not (or does it? Changed, test!) - it causes an * error. * * FIXME NRE! */ void | > > > > > > > > > > > > > | | > > > > > > > > | > > > > > > > > > > | | | < < | | | < | | > > | | < | | < < < < | | | < > > > > | < | < < < < < < < < < < | 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 |
* implementation does not (or does it? Changed, test!) - it causes an
* error.
*
* FIXME NRE!
*/
void
TclMarkTailcall(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
if (iPtr->deferredCallbacks == NULL) {
TclNRAddCallback(interp, NRCommand, NULL, NULL,
NULL, NULL);
iPtr->deferredCallbacks = TOP_CB(interp);
}
}
void
TclSkipTailcall(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
TclMarkTailcall(interp);
iPtr->deferredCallbacks->data[1] = INT2PTR(1);
}
void
TclPushTailcallPoint(
Tcl_Interp *interp)
{
TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
((Interp *) interp)->numLevels++;
}
void
TclSetTailcall(
Tcl_Interp *interp,
Tcl_Obj *listPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
* being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
* (used by command redirectors).
*/
NRE_callback *runPtr;
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
runPtr->data[1] = listPtr;
}
int
TclNRTailcallObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?");
return TCL_ERROR;
}
if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc or lambda", -1));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
return TCL_ERROR;
}
/*
* Invocation without args just clears a scheduled tailcall; invocation
* with an argument replaces any previously scheduled tailcall.
*/
if (iPtr->varFramePtr->tailcallPtr) {
Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
}
/*
* Create the callback to actually evaluate the tailcalled
* command, then set it in the varFrame so that PopCallFrame can use it
* at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
* build the callback.
*/
if (objc > 1) {
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
/* The tailcall data is in a Tcl list: the first element is the
* namespace, the rest the command to be tailcalled. */
listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("Tailcall failed to find the proper namespace");
}
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
iPtr->varFramePtr->tailcallPtr = listPtr;
}
return TCL_RETURN;
}
int
TclNRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
if (result != TCL_OK) {
/*
* Tailcall execution was preempted, eg by an intervening catch or by
* a now-gone namespace: cleanup and return.
*/
TailcallCleanup(data, interp, result);
return result;
}
/*
* Perform the tailcall
*/
TclMarkTailcall(interp);
TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
static int
TailcallCleanup(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_DecrRefCount((Tcl_Obj *) data[0]);
return result;
}
void
Tcl_NRAddCallback(
Tcl_Interp *interp,
Tcl_NRPostProc *postProcPtr,
ClientData data0,
ClientData data1,
|
| ︙ | ︙ | |||
8474 8475 8476 8477 8478 8479 8480 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
return TCL_ERROR;
}
if (!corPtr) {
| > | < | | 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 |
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
return TCL_ERROR;
}
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yield can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
}
if (objc == 2) {
Tcl_SetObjResult(interp, objv[1]);
}
NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
ClientData clientData,
|
| ︙ | ︙ | |||
8508 8509 8510 8511 8512 8513 8514 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
if (!corPtr) {
| > | < > > > > > > | < > | | < < < < < < < < < < < < < < < < < < < < < < < < | 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yieldto can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
return TCL_ERROR;
}
/*
* Add the tailcall in the caller env, then just yield.
*
* This is essentially code from TclNRTailcallObjCmd
*/
/*
* Add the tailcall in the caller env, then just yield.
*
* This is essentially code from TclNRTailcallObjCmd
*/
listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("yieldto failed to find the proper namespace");
}
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
TclSetTailcall(interp, listPtr);
iPtr->execEnvPtr = corPtr->eePtr;
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
static int
RewindCoroutineCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
|
| ︙ | ︙ | |||
8589 8590 8591 8592 8593 8594 8595 |
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
NRE_ASSERT(corPtr->eePtr != NULL);
NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);
corPtr->eePtr->rewind = 1;
TclNRAddCallback(interp, RewindCoroutineCallback, state,
NULL, NULL, NULL);
| | | 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 |
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
NRE_ASSERT(corPtr->eePtr != NULL);
NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);
corPtr->eePtr->rewind = 1;
TclNRAddCallback(interp, RewindCoroutineCallback, state,
NULL, NULL, NULL);
return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
DeleteCoroutine(
ClientData clientData)
{
CoroutineData *corPtr = clientData;
|
| ︙ | ︙ | |||
8702 8703 8704 8705 8706 8707 8708 |
return result;
}
/*
*----------------------------------------------------------------------
*
| | | | | 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 |
return result;
}
/*
*----------------------------------------------------------------------
*
* TclNRCoroutineActivateCallback --
*
* This is the workhorse for coroutines: it implements both yield and
* resume.
*
* It is important that both be implemented in the same callback: the
* detection of the impossibility to suspend due to a busy C-stack relies
* on the precise position of a local variable in the stack. We do not
* want the compiler to play tricks on us, either by moving things around
* or inlining.
*
*----------------------------------------------------------------------
*/
int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = data[0];
int type = PTR2INT(data[1]);
int numLevels, unused;
|
| ︙ | ︙ | |||
8757 8758 8759 8760 8761 8762 8763 |
iPtr->numLevels += numLevels;
} else {
/*
* Coroutine is active: yield
*/
if (corPtr->stackLevel != stackLevel) {
| > | < | 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 |
iPtr->numLevels += numLevels;
} else {
/*
* Coroutine is active: yield
*/
if (corPtr->stackLevel != stackLevel) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot yield: C stack busy", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
NULL);
return TCL_ERROR;
}
if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
|
| ︙ | ︙ | |||
8816 8817 8818 8819 8820 8821 8822 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
| | > | < | | | | | < | > | 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 |
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only inject a command into a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
corPtr = cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only inject a command into a suspended coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
return TCL_ERROR;
}
/*
* Add the callback to the coro's execEnv, so that it is the first thing
* to happen when the coro is resumed.
*/
iPtr->execEnvPtr = corPtr->eePtr;
TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN);
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
int
TclNRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
CoroutineData *corPtr = clientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
Tcl_GetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
/*
* Parse all the arguments to work out what to feed as the result of the
* [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine
|
| ︙ | ︙ | |||
8892 8893 8894 8895 8896 8897 8898 |
case COROUTINE_ARGUMENTS_ARBITRARY:
if (objc > 1) {
Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1));
}
break;
}
| | | 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 |
case COROUTINE_ARGUMENTS_ARBITRARY:
if (objc > 1) {
Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1));
}
break;
}
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
8937 8938 8939 8940 8941 8942 8943 |
*/
fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
| | | > | | > > | | < | | | 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 |
*/
fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\" in non-global namespace with"
" name starting with \":\"", procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
corPtr = ckalloc(sizeof(CoroutineData));
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, procName, -1);
cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
/*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
Tcl_DStringFree(&ds);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
/*
* #280.
|
| ︙ | ︙ | |||
9016 9017 9018 9019 9020 9021 9022 |
corPtr->running.framePtr = iPtr->rootFramePtr;
corPtr->running.varFramePtr = iPtr->rootFramePtr;
corPtr->running.cmdFramePtr = NULL;
corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
corPtr->stackLevel = NULL;
corPtr->auxNumLevels = 0;
| < > > | < | | 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 |
corPtr->running.framePtr = iPtr->rootFramePtr;
corPtr->running.varFramePtr = iPtr->rootFramePtr;
corPtr->running.cmdFramePtr = NULL;
corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
corPtr->stackLevel = NULL;
corPtr->auxNumLevels = 0;
/*
* Create the coro's execEnv, switch to it to push the exit and coro
* command callbacks, then switch back.
*/
corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE);
corPtr->callerEEPtr = iPtr->execEnvPtr;
corPtr->eePtr->corPtr = corPtr;
SAVE_CONTEXT(corPtr->caller);
corPtr->callerEEPtr = iPtr->execEnvPtr;
RESTORE_CONTEXT(corPtr->running);
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
/* insure that the command is looked up in the correct namespace */
iPtr->lookupNsPtr = lookupNsPtr;
Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
iPtr->numLevels--;
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
iPtr->execEnvPtr = corPtr->callerEEPtr;
/*
* Now just resume the coroutine.
*/
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
/*
* This is used in the [info] ensemble
*/
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',
'o', 'p', 'q', 'r', 's', 't', 'u', 'v',
'w', 'x', 'y', 'z', '0', '1', '2', '3',
'4', '5', '6', '7', '8', '9', '+', '/',
'='
};
/*
* 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
| > > > > > > > > > > > > > > > > > > > > > > > > | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',
'o', 'p', 'q', 'r', 's', 't', 'u', 'v',
'w', 'x', 'y', 'z', '0', '1', '2', '3',
'4', '5', '6', '7', '8', '9', '+', '/',
'='
};
/*
* How to construct the ensembles.
*/
static const EnsembleImplMap binaryMap[] = {
{ "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
{ "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 },
{ "encode", NULL, NULL, NULL, NULL, 0 },
{ "decode", NULL, NULL, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
static const EnsembleImplMap encodeMap[] = {
{ "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 },
{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 },
{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
static const EnsembleImplMap decodeMap[] = {
{ "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{ NULL, NULL, NULL, NULL, NULL, 0 }
};
/*
* 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
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclFreeIntRep(objPtr);
Tcl_InvalidateStringRep(objPtr);
| > | > | | | < < | < < | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclFreeIntRep(objPtr);
Tcl_InvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
}
byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
}
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 | * * Side effects: * Creates a new binary command as a mapped ensemble. * *---------------------------------------------------------------------- */ | < < < < < < < < < < < < < < < < < < < < | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
*
* Side effects:
* Creates a new binary command as a mapped ensemble.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclInitBinaryCmd(
Tcl_Interp *interp)
{
Tcl_Command binaryEnsemble;
binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap);
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
return TCL_ERROR;
}
arg++;
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
| | | | | < | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
return TCL_ERROR;
}
arg++;
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number of elements in list does not match count",
-1));
return TCL_ERROR;
}
}
offset += count*size;
break;
case 'x':
if (count == BINARY_ALL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use \"*\" in format string with \"x\"", -1));
return TCL_ERROR;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
offset += count;
break;
case 'X':
|
| ︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 |
}
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
badValue:
Tcl_ResetResult(interp);
| | | > > | | | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 |
}
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
badValue:
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected %s string but got \"%s\" instead",
errorString, errorValue));
return TCL_ERROR;
badCount:
errorString = "missing count for \"@\" field specifier";
goto error;
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
error:
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BinaryScanCmd --
|
| ︙ | ︙ | |||
1582 1583 1584 1585 1586 1587 1588 |
badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
| > | | | 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
error:
Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* GetFormatSpec --
|
| ︙ | ︙ | |||
2353 2354 2355 2356 2357 2358 2359 |
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
int i, index, value, size, count = 0, cut = 0, strict = 0;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
| | | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
int i, index, value, size, count = 0, cut = 0, strict = 0;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2567 2568 2569 2570 2571 2572 2573 |
unsigned char *begin, *cursor;
int i, index, size, count = 0, cut = 0, strict = 0;
char c;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
| | | 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 |
unsigned char *begin, *cursor;
int i, index, size, count = 0, cut = 0, strict = 0;
char c;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2654 2655 2656 2657 2658 2659 2660 |
BinaryDecode64(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
| | | | | 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 |
BinaryDecode64(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
int strict = 0;
int i, index, size, cut = 0, count = 0;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
TclGetStringFromObj(objv[objc-1], &count);
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
| > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | | | | | | | | | | | | < | < < | | | | < < < < < | > > > > > | | > > > > > > > > > | 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 |
TclGetStringFromObj(objv[objc-1], &count);
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
/*
* Decode the current block. Each base64 block consists of four input
* characters A-Z, a-z, 0-9, +, or /. Each character supplies six bits
* of output data, so each block's output is 24 bits (three bytes) in
* length. The final block can be shorter by one or two bytes, denoted
* by the input ending with one or two ='s, respectively.
*/
for (i = 0; i < 4; i++) {
/*
* Get the next input character. At end of input, pad with at most
* two ='s. If more than two ='s would be needed, instead discard
* the block read thus far.
*/
if (data < dataend) {
c = *data++;
} else if (i > 1) {
c = '=';
} else {
cut += 3;
break;
}
/*
* Load the character into the block value. Handle ='s specially
* because they're only valid as the last character or two of the
* final block of input. Unless strict mode is enabled, skip any
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
} else if (!strict && isspace(c)) {
i--;
} else {
goto bad64;
}
} else if (c >= 'A' && c <= 'Z') {
value = (value << 6) | ((c - 'A') & 0x3f);
} else if (c >= 'a' && c <= 'z') {
value = (value << 6) | ((c - 'a' + 26) & 0x3f);
} else if (c >= '0' && c <= '9') {
value = (value << 6) | ((c - '0' + 52) & 0x3f);
} else if (c == '+') {
value = (value << 6) | 0x3e;
} else if (c == '/') {
value = (value << 6) | 0x3f;
} else if (c == '=') {
value <<= 6;
cut++;
} else if (strict || !isspace(c)) {
goto bad64;
} else {
i--;
}
}
*cursor++ = UCHAR((value >> 16) & 0xff);
*cursor++ = UCHAR((value >> 8) & 0xff);
*cursor++ = UCHAR(value & 0xff);
/*
* Since = is only valid within the final block, if it was encountered
* but there are still more input characters, confirm that strict mode
* is off and all subsequent characters are whitespace.
*/
if (cut && data < dataend) {
if (strict) {
goto bad64;
}
for (; data < dataend; data++) {
if (!isspace(*data)) {
goto bad64;
}
}
}
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
bad64:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ |
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | * * Display the global memory management statistics. * *---------------------------------------------------------------------- */ int | | > > | > > | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
*
* Display the global memory management statistics.
*
*----------------------------------------------------------------------
*/
int
TclDumpMemoryInfo(
ClientData clientData,
int flags)
{
char buf[1024];
if (clientData == NULL) {
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",
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (argc < 2) {
| | | | > | | | > | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (argc < 2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: should be \"%s option [args..]\"", argv[0]));
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]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
argv[2], Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
if (argc != 3) {
goto argError;
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", (unsigned long)current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
return TCL_OK;
}
| | | | | > | > | | | | | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 |
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", (unsigned long)current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1], "init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(argv[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]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot open output file: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
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]));
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
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]));
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
len = strlen(argv[2]);
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
if (argc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
| | | | > | | | | | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
if (argc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(argv[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]));
return TCL_ERROR;
argError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
return TCL_ERROR;
bad_suboption:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CheckmemCmd --
|
| ︙ | ︙ | |||
977 978 979 980 981 982 983 |
CheckmemCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for evaluation. */
int argc, /* Number of arguments. */
const char *argv[]) /* String values of arguments. */
{
if (argc != 2) {
| | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
CheckmemCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for evaluation. */
int argc, /* Number of arguments. */
const char *argv[]) /* String values of arguments. */
{
if (argc != 2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: should be \"%s fileName\"", argv[0]));
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
strcpy(tclMemDumpFileName, argv[1]);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 |
Tcl_ValidateAllMemory(
const char *file,
int line)
{
}
int
| | > > | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
Tcl_ValidateAllMemory(
const char *file,
int line)
{
}
int
TclDumpMemoryInfo(
ClientData clientData,
int flags)
{
return 1;
}
#endif /* TCL_MEM_DEBUG */
/*
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
/*
* If conversion fails, report an error.
*/
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
| > | < | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 |
/*
* If conversion fails, report an error.
*/
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"time value too large/small to represent", -1));
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
/*
* Use 'localtime' to determine local year, month, day, time of day.
*/
tock = (time_t) fields->seconds;
if ((Tcl_WideInt) tock != fields->seconds) {
| | | | | | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
/*
* Use 'localtime' to determine local year, month, day, time of day.
*/
tock = (time_t) fields->seconds;
if ((Tcl_WideInt) tock != fields->seconds) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number too large to represent as a Posix time", -1));
Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL);
return TCL_ERROR;
}
TzsetIfNecessary();
timeVal = ThreadSafeLocalTime(&tock);
if (timeVal == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"localtime failed (clock value may be too "
"large/small to represent)", -1));
Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL);
return TCL_ERROR;
}
/*
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclCmdAH.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters A to H. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <locale.h> /* * The state structure used by [foreach]. Note that the actual structure has * all its working arrays appended afterwards so they can be allocated and * freed in a single step. | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclCmdAH.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters A to H. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <sys/stat.h> #include "tclInt.h" #include <locale.h> /* * The state structure used by [foreach]. Note that the actual structure has * all its working arrays appended afterwards so they can be allocated and * freed in a single step. |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
int *index; /* Array of value list indices. */
int *varcList; /* # loop variables per list. */
Tcl_Obj ***varvList; /* Array of var name lists. */
Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
int *argcList; /* Array of value list sizes. */
Tcl_Obj ***argvList; /* Array of value lists. */
Tcl_Obj **aCopyList; /* Copies of value list arguments. */
};
/*
* Prototypes for local procedures defined in this file:
*/
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
static int EncodingDirsObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline int ForeachAssignments(Tcl_Interp *interp,
struct ForeachState *statePtr);
static inline void ForeachCleanup(Tcl_Interp *interp,
struct ForeachState *statePtr);
static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
static const char * GetTypeFromMode(int mode);
static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
Tcl_StatBuf *statPtr);
static Tcl_NRPostProc CatchObjCmdCallback;
static Tcl_NRPostProc ExprCallback;
static Tcl_NRPostProc ForSetupCallback;
static Tcl_NRPostProc ForCondCallback;
static Tcl_NRPostProc ForNextCallback;
static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
| > > > > > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
int *index; /* Array of value list indices. */
int *varcList; /* # loop variables per list. */
Tcl_Obj ***varvList; /* Array of var name lists. */
Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
int *argcList; /* Array of value list sizes. */
Tcl_Obj ***argvList; /* Array of value lists. */
Tcl_Obj **aCopyList; /* Copies of value list arguments. */
Tcl_Obj *resultList; /* List of result values from the loop body,
* or NULL if we're not collecting them
* ([lmap] vs [foreach]). */
};
/*
* Prototypes for local procedures defined in this file:
*/
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
static int EncodingDirsObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline int ForeachAssignments(Tcl_Interp *interp,
struct ForeachState *statePtr);
static inline void ForeachCleanup(Tcl_Interp *interp,
struct ForeachState *statePtr);
static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
static const char * GetTypeFromMode(int mode);
static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
Tcl_StatBuf *statPtr);
static inline int EachloopCmd(Tcl_Interp *interp, int collect,
int objc, Tcl_Obj *const objv[]);
static Tcl_NRPostProc CatchObjCmdCallback;
static Tcl_NRPostProc ExprCallback;
static Tcl_NRPostProc ForSetupCallback;
static Tcl_NRPostProc ForCondCallback;
static Tcl_NRPostProc ForNextCallback;
static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
int patObjc, j;
const char **patObjv;
const char *pat;
unsigned char *p;
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
| > | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
int patObjc, j;
const char **patObjv;
const char *pat;
unsigned char *p;
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"extra case pattern with no body", -1));
return TCL_ERROR;
}
/*
* Check for special case of single pattern (no list) with no
* backslash sequences.
*/
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
}
}
if (objc == 4) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
options, TCL_LEAVE_ERR_MSG)) {
| | > | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
}
}
if (objc == 4) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
options, TCL_LEAVE_ERR_MSG)) {
/* Do not decrRefCount 'options', it was already done by
* Tcl_ObjSetVar2 */
return TCL_ERROR;
}
}
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 |
Tcl_IncrRefCount(dir);
}
if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
result = TCL_ERROR;
} else {
result = Tcl_FSChdir(dir);
if (result != TCL_OK) {
| > | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
Tcl_IncrRefCount(dir);
}
if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
result = TCL_ERROR;
} else {
result = Tcl_FSChdir(dir);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't change working directory to \"%s\": %s",
TclGetString(dir), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
}
if (objc != 2) {
Tcl_DecrRefCount(dir);
}
return result;
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 632 |
int
EncodingDirsObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc > 3) {
| > > | < < | > > | > | | | | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
int
EncodingDirsObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dirListObj;
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?dirList?");
return TCL_ERROR;
}
if (objc == 2) {
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
}
dirListObj = objv[2];
if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected directory list but got \"%s\"",
TclGetString(dirListObj)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, dirListObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ErrorObjCmd --
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
/*
* Note that most subcommands are unsafe because either they manipulate
* the native filesystem or because they reveal information about the
* native filesystem.
*/
static const EnsembleImplMap initMap[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
/*
* Note that most subcommands are unsafe because either they manipulate
* the native filesystem or because they reveal information about the
* native filesystem.
*/
static const EnsembleImplMap initMap[] = {
{"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
{"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},
{"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},
{"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},
{"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"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},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 |
{"writable", 1},
{NULL, 0}
};
int i;
Tcl_DString oldBuf, newBuf;
Tcl_DStringInit(&oldBuf);
| | | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 |
{"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);
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
return TCL_ERROR;
}
tval.actime = newTime;
tval.modtime = buf.st_mtime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
| > | | < | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
return TCL_ERROR;
}
tval.actime = newTime;
tval.modtime = buf.st_mtime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set access time for file \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the new recognized
* atime - hopefully the same as the one we sent in. However, fs's
* like FAT don't even know what atime is.
|
| ︙ | ︙ | |||
1231 1232 1233 1234 1235 1236 1237 |
return TCL_ERROR;
}
tval.actime = buf.st_atime;
tval.modtime = newTime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
| > | < | | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 |
return TCL_ERROR;
}
tval.actime = buf.st_atime;
tval.modtime = newTime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set modification time for file \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the new recognized
* mtime - hopefully the same as the one we sent in.
*/
|
| ︙ | ︙ | |||
1836 1837 1838 1839 1840 1841 1842 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
| | | 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fsInfo);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
res = Tcl_FSSplitPath(objv[1], NULL);
if (res == NULL) {
| | | > | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
res = Tcl_FSSplitPath(objv[1], NULL);
if (res == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 |
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1));
} else {
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
| > | | 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 |
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1));
} else {
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, separatorObj);
}
return TCL_OK;
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
return TCL_ERROR;
}
status = statProc(pathPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
| > | | < | 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 |
return TCL_ERROR;
}
status = statProc(pathPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 |
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return result;
}
/*
*----------------------------------------------------------------------
*
| | | 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 |
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd --
*
* This object-based procedure is invoked to process the "foreach" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
|
| ︙ | ︙ | |||
2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 |
int
TclNRForeachCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int numLists = (objc-2) / 2;
register struct ForeachState *statePtr;
int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 |
int
TclNRForeachCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv);
}
int
Tcl_LmapObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv);
}
int
TclNRLmapCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
static inline int
EachloopCmd(
Tcl_Interp *interp, /* Our context for variables and script
* evaluation. */
int collect, /* Select collecting or accumulating mode
* (TCL_EACH_*) */
int objc, /* The arguments being passed in... */
Tcl_Obj *const objv[])
{
int numLists = (objc-2) / 2;
register struct ForeachState *statePtr;
int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 |
statePtr->index = (int *) (statePtr->aCopyList + numLists);
statePtr->varcList = statePtr->index + numLists;
statePtr->argcList = statePtr->varcList + numLists;
statePtr->numLists = numLists;
statePtr->bodyPtr = objv[objc - 1];
statePtr->bodyIdx = objc - 1;
/*
* Break up the value lists and variable lists into elements.
*/
for (i=0 ; i<numLists ; i++) {
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
| > > > > > > > | > | > | 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 |
statePtr->index = (int *) (statePtr->aCopyList + numLists);
statePtr->varcList = statePtr->index + numLists;
statePtr->argcList = statePtr->varcList + numLists;
statePtr->numLists = numLists;
statePtr->bodyPtr = objv[objc - 1];
statePtr->bodyIdx = objc - 1;
if (collect == TCL_EACH_COLLECT) {
statePtr->resultList = Tcl_NewListObj(0, NULL);
} else {
statePtr->resultList = NULL;
}
/*
* Break up the value lists and variable lists into elements.
*/
for (i=0 ; i<numLists ; i++) {
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s varlist is empty",
(statePtr->resultList != NULL ? "lmap" : "foreach")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
(statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
"NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
}
statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
|
| ︙ | ︙ | |||
2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 |
* Process the result code from this run of the [foreach] body. Note that
* this switch uses fallthroughs in several places. Maintainer aware!
*/
switch (result) {
case TCL_CONTINUE:
result = TCL_OK;
case TCL_OK:
break;
case TCL_BREAK:
result = TCL_OK;
| > > > > > | > > | | 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 |
* Process the result code from this run of the [foreach] body. Note that
* this switch uses fallthroughs in several places. Maintainer aware!
*/
switch (result) {
case TCL_CONTINUE:
result = TCL_OK;
break;
case TCL_OK:
if (statePtr->resultList != NULL) {
Tcl_ListObjAppendElement(interp, statePtr->resultList,
Tcl_GetObjResult(interp));
}
break;
case TCL_BREAK:
result = TCL_OK;
goto finish;
case TCL_ERROR:
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%s\" body line %d)",
(statePtr->resultList != NULL ? "lmap" : "foreach"),
Tcl_GetErrorLine(interp)));
default:
goto done;
}
/*
* Test if there is work still to be done. If so, do the next round of
* variable assignments, reschedule ourselves and run the body again.
|
| ︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 |
((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx);
}
/*
* We're done. Tidy up our work space and finish off.
*/
| > > | > > > > > | 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 |
((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx);
}
/*
* We're done. Tidy up our work space and finish off.
*/
finish:
if (statePtr->resultList == NULL) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, statePtr->resultList);
statePtr->resultList = NULL; /* Don't clean it up */
}
done:
ForeachCleanup(interp, statePtr);
return result;
}
/*
* Factored out code to do the assignments in [foreach].
|
| ︙ | ︙ | |||
2778 2779 2780 2781 2782 2783 2784 |
}
varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
| | > | 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 |
}
varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (setting %s loop variable \"%s\")",
(statePtr->resultList != NULL ? "lmap" : "foreach"),
TclGetString(statePtr->varvList[i][v])));
return TCL_ERROR;
}
}
}
return TCL_OK;
|
| ︙ | ︙ | |||
2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 |
for (i=0 ; i<statePtr->numLists ; i++) {
if (statePtr->vCopyList[i]) {
TclDecrRefCount(statePtr->vCopyList[i]);
}
if (statePtr->aCopyList[i]) {
TclDecrRefCount(statePtr->aCopyList[i]);
}
}
TclStackFree(interp, statePtr);
}
/*
*----------------------------------------------------------------------
*
| > > > | 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 |
for (i=0 ; i<statePtr->numLists ; i++) {
if (statePtr->vCopyList[i]) {
TclDecrRefCount(statePtr->vCopyList[i]);
}
if (statePtr->aCopyList[i]) {
TclDecrRefCount(statePtr->aCopyList[i]);
}
}
if (statePtr->resultList != NULL) {
TclDecrRefCount(statePtr->resultList);
}
TclStackFree(interp, statePtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
/*
* During execution of the "lsort" command, structures of the following type
* are used to arrange the objects being sorted into a collection of linked
* lists.
*/
typedef struct SortElement {
| | | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
/*
* During execution of the "lsort" command, structures of the following type
* are used to arrange the objects being sorted into a collection of linked
* lists.
*/
typedef struct SortElement {
union { /* The value that we sorting by. */
const char *strValuePtr;
long intValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
union { /* Object being sorted, or its index. */
Tcl_Obj *objPtr;
int index;
} payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
} SortElement;
/*
* These function pointer types are used with the "lsearch" and "lsort"
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
/*
* Array of values describing how to implement each standard subcommand of the
* "info" command.
*/
static const EnsembleImplMap defaultInfoMap[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
/*
* Array of values describing how to implement each standard subcommand of the
* "info" command.
*/
static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
{"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
{"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
{"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* Tcl_IfObjCmd --
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *boolObj;
if (objc <= 1) {
| > | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *boolObj;
if (objc <= 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
/*
* At this point, objv[1] refers to the main expression to test. The
* arguments after the expression must be "then" (optional) and a script
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 |
* At this point in the loop, objv and objc refer to an expression to
* test, either for the main expression or an expression following an
* "elseif". The arguments after the expression must be "then"
* (optional) and a script to execute if the expression is true.
*/
if (i >= objc) {
| | | > | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
* At this point in the loop, objv and objc refer to an expression to
* test, either for the main expression or an expression following an
* "elseif". The arguments after the expression must be "then"
* (optional) and a script to execute if the expression is true.
*/
if (i >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
clause));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
if (!thenScriptIndex) {
TclNewObj(boolObj);
Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1],
INT2PTR(i), boolObj);
|
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
if (strcmp(clause, "else") == 0) {
i++;
if (i >= objc) {
goto missingScript;
}
}
if (i < objc - 1) {
| | | > > > | < < | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
if (strcmp(clause, "else") == 0) {
i++;
if (i >= objc) {
goto missingScript;
}
}
if (i < objc - 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args: extra words after \"else\" clause in \"if\" command",
-1));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
/*
* TIP #280. Make invoking context available to branch/else.
*/
return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr, thenScriptIndex);
}
return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
missingScript:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no script following \"%s\" argument",
TclGetString(objv[i-1])));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
487 488 489 490 491 492 493 |
Tcl_WrongNumArgs(interp, 1, objv, "procname");
return TCL_ERROR;
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
| > | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
Tcl_WrongNumArgs(interp, 1, objv, "procname");
return TCL_ERROR;
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
/*
* Build a return list containing the arguments.
*/
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
Tcl_WrongNumArgs(interp, 1, objv, "procname");
return TCL_ERROR;
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
| > | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 |
Tcl_WrongNumArgs(interp, 1, objv, "procname");
return TCL_ERROR;
}
name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
return TCL_ERROR;
}
/*
* Here we used to return procPtr->bodyPtr, except when the body was
* bytecompiled - in that case, the return was a copy of the body's string
|
| ︙ | ︙ | |||
977 978 979 980 981 982 983 |
}
procName = TclGetString(objv[1]);
argName = TclGetString(objv[2]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
| > | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 |
}
procName = TclGetString(objv[1]);
argName = TclGetString(objv[2]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
NULL);
return TCL_ERROR;
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
}
return TCL_OK;
}
}
| | | > | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 |
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
}
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\" doesn't have an argument \"%s\"",
procName, argName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1051 1052 1053 1054 1055 1056 1057 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
| | | | | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
}
iPtr = (Interp *) target;
Tcl_SetObjResult(interp, iPtr->errorStack);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 1161 1162 |
: iPtr->cmdFramePtr->level);
if (corPtr) {
/*
* A coroutine: must fix the level computations AND the cmdFrame chain,
* which is interrupted at the base.
*/
CmdFrame *lastPtr = NULL;
| > | | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 |
: iPtr->cmdFramePtr->level);
if (corPtr) {
/*
* A coroutine: must fix the level computations AND the cmdFrame chain,
* which is interrupted at the base.
*/
CmdFrame *lastPtr = NULL;
runPtr = iPtr->cmdFramePtr;
/* TODO - deal with overflow */
topLevel += corPtr->caller.cmdFramePtr->level;
while (runPtr) {
runPtr->level += corPtr->caller.cmdFramePtr->level;
lastPtr = runPtr;
runPtr = runPtr->nextPtr;
}
if (lastPtr) {
lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
|
| ︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 |
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
code = TCL_ERROR;
goto done;
}
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
| > | < | 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
code = TCL_ERROR;
goto done;
}
if ((level > topLevel) || (level <= - topLevel)) {
levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
TclGetString(objv[1]), NULL);
code = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 |
* Procedure CallFrame.
*/
if (procPtr != NULL) {
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
| | | | | | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
* Procedure CallFrame.
*/
if (procPtr != NULL) {
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
if (namePtr) {
Tcl_Obj *procNameObj;
/*
* This is a regular command.
*/
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
int i;
/*
* This is a non-standard command. Luckily, it's told us how to
|
| ︙ | ︙ | |||
1480 1481 1482 1483 1484 1485 1486 |
static int
InfoFunctionsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| > | | < < < < > > > > > > > > > > > > > > | > > > > > > > > > > > > | | 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 |
static int
InfoFunctionsCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *script;
int code;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
return TCL_ERROR;
}
script = Tcl_NewStringObj(
" ::apply [::list {{pattern *}} {\n"
" ::set cmds {}\n"
" ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n"
" ::lappend cmds [::namespace tail $cmd]\n"
" }\n"
" ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n"
" ::set cmd [::namespace tail $cmd]\n"
" ::if {$cmd ni $cmds} {\n"
" ::lappend cmds $cmd\n"
" }\n"
" }\n"
" ::return $cmds\n"
" } [::namespace current]] ", -1);
if (objc == 2) {
Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1]));
Tcl_AppendObjToObj(script, arg);
Tcl_DecrRefCount(arg);
}
Tcl_IncrRefCount(script);
code = Tcl_EvalObjEx(interp, script, 0);
Tcl_DecrRefCount(script);
return code;
}
/*
*----------------------------------------------------------------------
*
* InfoHostnameCmd --
*
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
}
name = Tcl_GetHostName();
if (name) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
| > > | | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 |
}
name = Tcl_GetHostName();
if (name) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to determine name of host", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 |
return TCL_OK;
}
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
return TCL_ERROR;
levelError:
| > | < | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 |
return TCL_OK;
}
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
return TCL_ERROR;
levelError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1652 1653 1654 1655 1656 1657 1658 |
}
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
| > > | | 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
}
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no library has been specified for Tcl", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2586 2587 2588 2589 2590 2591 2592 |
Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
| | | | > | | 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 |
Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad count \"%d\": must be integer >= 0", elementCount));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
NULL);
return TCL_ERROR;
}
/*
* Skip forward to the interesting arguments now we've finished parsing.
*/
objc -= 2;
objv += 2;
/* Final sanity check. Do not exceed limits on max list length. */
if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded", LIST_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
/*
* Get an empty list object that is allocated large enough to hold each
* init value elementCount times.
|
| ︙ | ︙ | |||
2719 2720 2721 2722 2723 2724 2725 |
* Complain if the user asked for a start element that is greater than the
* list length. This won't ever trigger for the "end-*" case as that will
* be properly constrained by TclGetIntForIndex because we use listLen-1
* (to allow for replacing the last elem).
*/
if ((first >= listLen) && (listLen > 0)) {
| | | | > | 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 |
* Complain if the user asked for a start element that is greater than the
* list length. This won't ever trigger for the "end-*" case as that will
* be properly constrained by TclGetIntForIndex because we use listLen-1
* (to allow for replacing the last elem).
*/
if ((first >= listLen) && (listLen > 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list doesn't contain element %s", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
NULL);
return TCL_ERROR;
}
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
numToDelete = last - first + 1;
|
| ︙ | ︙ | |||
2992 2993 2994 2995 2996 2997 2998 |
* because it will either be replaced or there will be an error.
*/
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
| > | | | 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
* because it will either be replaced or there will be an error.
*/
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing starting index", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
i++;
if (objv[i] == objv[objc - 2]) {
/*
* Take copy to prevent shimmering problems. Note that it does
|
| ︙ | ︙ | |||
3023 3024 3025 3026 3027 3028 3029 |
if (sortInfo.indexc > 1) {
TclStackFree(interp, sortInfo.indexv);
}
if (i > objc-4) {
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
| | | | | 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 |
if (sortInfo.indexc > 1) {
TclStackFree(interp, sortInfo.indexv);
}
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;
}
/*
* Store the extracted indices for processing by sublist
* extraction. Note that we don't do this using objects because
* that has shimmering problems.
|
| ︙ | ︙ | |||
3084 3085 3086 3087 3088 3089 3090 |
* Subindices only make sense if asked for with -index option set.
*/
if (returnSubindices && sortInfo.indexc==0) {
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
| | | | | | | | | | 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 |
* Subindices only make sense if asked for with -index option set.
*/
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;
}
if (bisect && (allMatches || negatedMatch)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
return TCL_ERROR;
}
if (mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
* regexp rep before the list rep. First time round, omit the interp
|
| ︙ | ︙ | |||
3527 3528 3529 3530 3531 3532 3533 |
/*
* Check parameter count.
*/
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
| | | 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 |
/*
* Check parameter count.
*/
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"listVar ?index? ?index ...? value");
return TCL_ERROR;
}
/*
* Look up the list variable's value.
*/
|
| ︙ | ︙ | |||
3660 3661 3662 3663 3664 3665 3666 |
}
switch ((enum Lsort_Switches) index) {
case LSORT_ASCII:
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
if (i == objc-2) {
| | | | | | | > | | | | | | | | | | | | | > | | | > | < | | | | | | | | | | | | | | | | | | | | 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 |
}
switch ((enum Lsort_Switches) index) {
case LSORT_ASCII:
sortInfo.sortMode = SORTMODE_ASCII;
break;
case LSORT_COMMAND:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
"by comparison command", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
sortInfo.sortMode = SORTMODE_COMMAND;
cmdPtr = objv[i+1];
i++;
break;
case LSORT_DECREASING:
sortInfo.isIncreasing = 0;
break;
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
int indexc, dummy;
Tcl_Obj **indexv;
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
if (TclListObjGetElements(interp, objv[i+1], &indexc,
&indexv) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
/*
* Check each of the indices for syntactic correctness. Note that
* we do not store the converted values here because we do not
* know if this is the only -index option yet and so we can't
* allocate any space; that happens after the scan through all the
* options is done.
*/
for (j=0 ; j<indexc ; j++) {
if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
&dummy) != TCL_OK) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
}
indexPtr = objv[i+1];
i++;
break;
}
case LSORT_INTEGER:
sortInfo.sortMode = SORTMODE_INTEGER;
break;
case LSORT_NOCASE:
nocase = 1;
break;
case LSORT_REAL:
sortInfo.sortMode = SORTMODE_REAL;
break;
case LSORT_UNIQUE:
sortInfo.unique = 1;
break;
case LSORT_INDICES:
indices = 1;
break;
case LSORT_STRIDE:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
if (groupSize < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"stride length must be at least 2", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
"BADSTRIDE", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done2;
}
group = 1;
i++;
break;
}
}
if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) {
sortInfo.sortMode = SORTMODE_ASCII_NC;
}
/*
* Now extract the -index list for real, if present. No failures are
* expected here; the values are all of the right type or convertible to
* it.
*/
if (indexPtr) {
Tcl_Obj **indexv;
TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
sortInfo.indexv =
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++) {
TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
&sortInfo.indexv[j]);
}
}
listObj = objv[objc-1];
if (sortInfo.sortMode == SORTMODE_COMMAND) {
Tcl_Obj *newCommandPtr, *newObjPtr;
|
| ︙ | ︙ | |||
3843 3844 3845 3846 3847 3848 3849 |
/*
* Check for sanity when grouping elements of the overall list together
* because of the -stride option. [TIP #326]
*/
if (group) {
if (length % groupSize) {
| | | | | > | | < | | | 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 |
/*
* Check for sanity when grouping elements of the overall list together
* because of the -stride option. [TIP #326]
*/
if (group) {
if (length % groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list size must be a multiple of the stride length",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
length = length / groupSize;
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 = sortInfo.indexv[0];
if (groupOffset <= SORTIDX_END) {
groupOffset = (groupOffset - SORTIDX_END) + 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", "LSORT",
"BADINDEX", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (sortInfo.indexc == 1) {
sortInfo.indexc = 0;
sortInfo.indexv = NULL;
} else {
|
| ︙ | ︙ | |||
4251 4252 4253 4254 4255 4256 4257 |
/*
* Parse the result of the command.
*/
if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
| < | | | | | 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 |
/*
* Parse the result of the command.
*/
if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
"-compare command returned non-integer result", -1));
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"COMPARISONFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
}
if (!infoPtr->isIncreasing) {
order = -order;
}
|
| ︙ | ︙ | |||
4466 4467 4468 4469 4470 4471 4472 |
if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
¤tObj) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
if (currentObj == NULL) {
| | | | | | < | 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 |
if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
¤tObj) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
if (currentObj == NULL) {
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;
return NULL;
}
objPtr = currentObj;
}
return objPtr;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | static int TryPostHandler(ClientData data[], Tcl_Interp *interp, int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a | | < < | > > > > > > > > > > > > > > > > > > > > > > > > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | static int TryPostHandler(ClientData data[], Tcl_Interp *interp, int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a * UTF-8 literal string containing all Unicode space characters [TIP #413] */ #define DEFAULT_TRIM_SET \ "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ "\xc0\x80" /* nul (U+0000) */\ "\xc2\x85" /* next line (U+0085) */\ "\xc2\xa0" /* non-breaking space (U+00a0) */\ "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ "\xe2\x80\x80" /* en quad (U+2000) */\ "\xe2\x80\x81" /* em quad (U+2001) */\ "\xe2\x80\x82" /* en space (U+2002) */\ "\xe2\x80\x83" /* em space (U+2003) */\ "\xe2\x80\x84" /* three-per-em space (U+2004) */\ "\xe2\x80\x85" /* four-per-em space (U+2005) */\ "\xe2\x80\x86" /* six-per-em space (U+2006) */\ "\xe2\x80\x87" /* figure space (U+2007) */\ "\xe2\x80\x88" /* punctuation space (U+2008) */\ "\xe2\x80\x89" /* thin space (U+2009) */\ "\xe2\x80\x8a" /* hair space (U+200a) */\ "\xe2\x80\x8b" /* zero width space (U+200b) */\ "\xe2\x80\xa8" /* line separator (U+2028) */\ "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ "\xe2\x81\xa0" /* word joiner (U+2060) */\ "\xe3\x80\x80" /* ideographic space (U+3000) */\ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * * This procedure is invoked to process the "pwd" Tcl command. See the |
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
/*
* Check if the user requested -inline, but specified match variables; a
* no-no.
*/
if (doinline && ((objc - 2) != 0)) {
| | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
/*
* Check if the user requested -inline, but specified match variables; a
* no-no.
*/
if (doinline && ((objc - 2) != 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"regexp match variables not allowed when using -inline", -1));
goto optionError;
}
/*
* Handle the odd about case separately.
*/
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
if (objc == 4) {
const char *string = TclGetStringFromObj(objv[1], &length2);
if ((length2 > 1) &&
strncmp(string, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
| | | | 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 |
if (objc == 4) {
const char *string = TclGetStringFromObj(objv[1], &length2);
if ((length2 > 1) &&
strncmp(string, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
2102 2103 2104 2105 2106 2107 2108 |
int length;
const char *string = TclGetStringFromObj(objv[1], &length);
if ((length > 1) &&
strncmp(string, "-nocase", (size_t) length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
| | | | 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 |
int length;
const char *string = TclGetStringFromObj(objv[1], &length);
if ((length > 1) &&
strncmp(string, "-nocase", (size_t) length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string, NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
TclStringMatchObj(objv[objc-1], objv[objc-2], nocase)));
|
| ︙ | ︙ | |||
2563 2564 2565 2566 2567 2568 2569 |
goto str_cmp_args;
}
i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
| | | > | 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 |
goto str_cmp_args;
}
i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase or -length",
string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string2, NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
2712 2713 2714 2715 2716 2717 2718 |
goto str_cmp_args;
}
i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
| | | > | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 |
goto str_cmp_args;
}
i++;
if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase or -length",
string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
string2, NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
3295 3296 3297 3298 3299 3300 3301 |
*/
Tcl_Command
TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
| | | | | | | | | | | | | | | | | 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 |
*/
Tcl_Command
TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
{"is", StringIsCmd, NULL, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
{"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
{"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"replace", StringRplcCmd, NULL, NULL, NULL, 0},
{"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "string", stringImplMap);
}
/*
|
| ︙ | ︙ | |||
3511 3512 3513 3514 3515 3516 3517 |
default:
if (foundmode) {
/*
* Mode already set via -exact, -glob, or -regexp.
*/
| | > | < > | | > | | | | | | | 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 |
default:
if (foundmode) {
/*
* Mode already set via -exact, -glob, or -regexp.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": %s option already found",
TclGetString(objv[i]), options[mode]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"DOUBLEOPT", NULL);
return TCL_ERROR;
}
foundmode = 1;
mode = index;
break;
/*
* Check for TIP#75 options specifying the variables to write
* regexp information into.
*/
case OPT_INDEXV:
i++;
if (i >= objc-2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing variable name argument to %s option",
"-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", NULL);
return TCL_ERROR;
}
indexVarObj = objv[i];
numMatchesSaved = -1;
break;
case OPT_MATCHV:
i++;
if (i >= objc-2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing variable name argument to %s option",
"-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"NOVAR", NULL);
return TCL_ERROR;
}
matchVarObj = objv[i];
numMatchesSaved = -1;
break;
}
}
finishedOptions:
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-switch ...? string ?pattern body ...? ?default body?");
return TCL_ERROR;
}
if (indexVarObj != NULL && mode != OPT_REGEXP) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s option requires -regexp option", "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", NULL);
return TCL_ERROR;
}
if (matchVarObj != NULL && mode != OPT_REGEXP) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s option requires -regexp option", "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"MODERESTRICTION", NULL);
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
|
| ︙ | ︙ | |||
3618 3619 3620 3621 3622 3623 3624 |
/*
* Complain if there is an odd number of words in the list of patterns and
* bodies.
*/
if (objc % 2) {
Tcl_ResetResult(interp);
| > | | | | | | | | | 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 |
/*
* Complain if there is an odd number of words in the list of patterns and
* bodies.
*/
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"extra switch pattern with no body", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
NULL);
/*
* Check if this can be due to a badly placed comment in the switch
* block.
*
* The following is an heuristic to detect the infamous "comment in
* switch" error: just check if a pattern begins with '#'.
*/
if (splitObjs) {
for (i=0 ; i<objc ; i+=2) {
if (TclGetString(objv[i])[0] == '#') {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
", this may be due to a comment incorrectly"
" placed outside of a switch body - see the"
" \"switch\" documentation", -1);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
"BADARM", "COMMENT?", NULL);
break;
}
}
}
return TCL_ERROR;
}
/*
* Complain if the last body is a continuation. Note that this check
* assumes that the list is non-empty!
*/
if (strcmp(TclGetString(objv[objc-1]), "-") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no body specified for pattern \"%s\"",
TclGetString(objv[objc-2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
"FALLTHROUGH", NULL);
return TCL_ERROR;
}
for (i = 0; i < objc; i += 2) {
/*
|
| ︙ | ︙ | |||
3981 3982 3983 3984 3985 3986 3987 |
/*
* The type must be a list of at least length 1.
*/
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
| > | | 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 |
/*
* The type must be a list of at least length 1.
*/
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
return TCL_ERROR;
} else if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"type must be non-empty list", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
NULL);
return TCL_ERROR;
}
/*
* Now prepare the result options dictionary. We use the list API as it is
|
| ︙ | ︙ | |||
4165 4166 4167 4168 4169 4170 4171 |
0, &type) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
switch ((enum Handlers) type) {
case TryFinally: /* finally script */
if (i < objc-2) {
| > | > | < | | | | | > > | | | 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 |
0, &type) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
switch ((enum Handlers) type) {
case TryFinally: /* finally script */
if (i < objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"finally clause must be last", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"NONTERMINAL", NULL);
return TCL_ERROR;
} else if (i == objc-1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args to finally clause: must be"
" \"... finally script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
"ARGUMENT", NULL);
return TCL_ERROR;
}
finallyObj = objv[++i];
break;
case TryOn: /* on code variableList script */
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args to on clause: must be \"... on code"
" variableList script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
"ARGUMENT", NULL);
return TCL_ERROR;
}
if (TclGetCompletionCodeFromObj(interp, objv[i+1],
&code) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
info[2] = NULL;
goto commonHandler;
case TryTrap: /* trap pattern variableList script */
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args to trap clause: "
"must be \"... trap pattern variableList script\"",
-1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"ARGUMENT", NULL);
return TCL_ERROR;
}
code = 1;
if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
|
| ︙ | ︙ | |||
4244 4245 4246 4247 4248 4249 4250 |
Tcl_NewListObj(5, info));
haveHandlers = 1;
i += 3;
break;
}
}
if (bodyShared) {
| | | < | 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 |
Tcl_NewListObj(5, info));
haveHandlers = 1;
i += 3;
break;
}
}
if (bodyShared) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"last non-finally clause must not have a body of \"-\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
NULL);
return TCL_ERROR;
}
if (!haveHandlers) {
Tcl_DecrRefCount(handlersObj);
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * * 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 "tclCompile.h" /* * Prototypes for procedures defined later in this file: */ static ClientData DupDictUpdateInfo(ClientData clientData); static void FreeDictUpdateInfo(ClientData clientData); | > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * * 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 "tclCompile.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ static ClientData DupDictUpdateInfo(ClientData clientData); static void FreeDictUpdateInfo(ClientData clientData); |
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp, int word); | > > > > > > > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int *clNext); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp, int word); |
| ︙ | ︙ | |||
95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
}
/*
* Flags bits used by PushVarName.
*/
#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
/*
* The structures below define the AuxData types defined in this file.
*/
const AuxDataType tclForeachInfoType = {
"ForeachInfo", /* name */
| > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
}
/*
* Flags bits used by PushVarName.
*/
#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
/*
* The structures below define the AuxData types defined in this file.
*/
const AuxDataType tclForeachInfoType = {
"ForeachInfo", /* name */
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileBreakCmd --
*
* Procedure called to compile the "break" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileArray*Cmd --
*
* Functions called to compile "array" sucommands.
*
* Results:
* All return TCL_OK for a successful compile, and TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "array" subcommand at
* runtime.
*
*----------------------------------------------------------------------
*/
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int simpleVarName, isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
} else {
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
}
return TCL_OK;
}
int
TclCompileArraySetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int simpleVarName, isScalar, localIndex;
int dataVar, iterVar, keyVar, valVar, infoIndex;
int back, fwd, offsetBack, offsetFwd, savedStackDepth;
ForeachInfo *infoPtr;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (envPtr->procPtr == NULL) {
Tcl_Token *tokPtr = TokenAfter(tokenPtr);
if (tokPtr->type != TCL_TOKEN_SIMPLE_WORD || tokPtr[1].size != 0) {
return TCL_ERROR;
}
}
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
/*
* Special case: literal empty value argument is just an "ensure array"
* operation.
*/
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
} else {
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr);
savedStackDepth = envPtr->currStackDepth;
TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
envPtr->currStackDepth = savedStackDepth;
TclEmitOpcode( INST_POP, envPtr);
}
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
* Prepare for the internal foreach.
*/
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->firstValueTemp = dataVar;
infoPtr->loopCtTemp = iterVar;
infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
*/
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_LIST_LENGTH, envPtr);
PushLiteral(envPtr, "1", 1);
TclEmitOpcode( INST_BITAND, envPtr);
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
savedStackDepth = envPtr->currStackDepth;
PushLiteral(envPtr, "list must have an even number of elements",
strlen("list must have an even number of elements"));
PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
strlen("-errorCode {TCL ARGUMENT FORMAT}"));
TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr);
TclEmitInt4( 0, envPtr);
envPtr->currStackDepth = savedStackDepth;
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
offsetBack = CurrentOffset(envPtr);
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
savedStackDepth = envPtr->currStackDepth;
Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
back = offsetBack - CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, back, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
envPtr->currStackDepth = savedStackDepth;
} else {
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
offsetBack = CurrentOffset(envPtr);
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
savedStackDepth = envPtr->currStackDepth;
TclEmitOpcode( INST_DUP, envPtr);
Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
TclEmitOpcode( INST_POP, envPtr);
back = offsetBack - CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, back, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
envPtr->currStackDepth = savedStackDepth;
TclEmitOpcode( INST_POP, envPtr);
}
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( dataVar, envPtr);
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
int
TclCompileArrayUnsetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int simpleVarName, isScalar, localIndex, savedStackDepth;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr);
TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr);
TclEmitInt4( localIndex, envPtr);
} else {
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr);
savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
envPtr->currStackDepth = savedStackDepth;
TclEmitOpcode( INST_POP, envPtr);
}
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileBreakCmd --
*
* Procedure called to compile the "break" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
}
/*
* Emit a break instruction.
*/
TclEmitOpcode(INST_BREAK, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileCatchCmd --
| > | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
}
/*
* Emit a break instruction.
*/
TclEmitOpcode(INST_BREAK, envPtr);
PushLiteral(envPtr, "", 0); /* Evil hack! */
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileCatchCmd --
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
}
/*
* Emit a continue instruction.
*/
TclEmitOpcode(INST_CONTINUE, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileDict*Cmd --
*
* Functions called to compile "dict" sucommands.
*
* Results:
* All return TCL_OK for a successful compile, and TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "dict" subcommand at
* runtime.
*
| > < < < < < < < < < < < < < < < < < < < | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
}
/*
* Emit a continue instruction.
*/
TclEmitOpcode(INST_CONTINUE, envPtr);
PushLiteral(envPtr, "", 0); /* Evil hack! */
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileDict*Cmd --
*
* Functions called to compile "dict" sucommands.
*
* Results:
* All return TCL_OK for a successful compile, and TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "dict" subcommand at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
/*
* Now emit the instruction to do the dict manipulation.
*/
TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
}
int
TclCompileDictIncrCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
| > | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
/*
* Now emit the instruction to do the dict manipulation.
*/
TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictIncrCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
| ︙ | ︙ | |||
771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
*/
for (i=0 ; i<numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
return TCL_OK;
}
int
TclCompileDictForCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
int numVars, endTargetOffset;
int savedStackDepth = envPtr->currStackDepth;
/* Needed because jumps confuse the stack
* space calculator. */
const char **argv;
Tcl_DString buffer;
/*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 |
*/
for (i=0 ; i<numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int numWords, i;
DefineLineInformation; /* TIP #280 */
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
numWords = parsePtr->numWords-1;
/*
* Now we do the code generation.
*/
for (i=0 ; i<numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
int
TclCompileDictUnsetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
int i, dictVarIndex, nameChars;
const char *name;
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
/*
* The dictionary variable must be a local scalar that is knowable at
* compile time; anything else exceeds the complexity of the opcode. So
* discover what the index is.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
name = tokenPtr[1].start;
nameChars = tokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
return TCL_ERROR;
}
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if (dictVarIndex < 0) {
return TCL_ERROR;
}
/*
* Remaining words (the key path) can be handled normally.
*/
for (i=2 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
/*
* Now emit the instruction to do the dict manipulation.
*/
TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
}
int
TclCompileDictCreateCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int worker; /* Temp var for building the value in. */
Tcl_Token *tokenPtr;
Tcl_Obj *keyObj, *valueObj, *dictObj;
const char *bytes;
int i, len;
if ((parsePtr->numWords & 1) == 0) {
return TCL_ERROR;
}
/*
* See if we can build the value at compile time...
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
dictObj = Tcl_NewObj();
Tcl_IncrRefCount(dictObj);
for (i=1 ; i<parsePtr->numWords ; i+=2) {
keyObj = Tcl_NewObj();
Tcl_IncrRefCount(keyObj);
if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) {
Tcl_DecrRefCount(keyObj);
Tcl_DecrRefCount(dictObj);
goto nonConstant;
}
tokenPtr = TokenAfter(tokenPtr);
valueObj = Tcl_NewObj();
Tcl_IncrRefCount(valueObj);
if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) {
Tcl_DecrRefCount(keyObj);
Tcl_DecrRefCount(valueObj);
Tcl_DecrRefCount(dictObj);
goto nonConstant;
}
tokenPtr = TokenAfter(tokenPtr);
Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj);
Tcl_DecrRefCount(keyObj);
Tcl_DecrRefCount(valueObj);
}
/*
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
bytes = Tcl_GetStringFromObj(dictObj, &len);
PushLiteral(envPtr, bytes, len);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
/*
* Otherwise, we've got to issue runtime code to do the building, which we
* do by [dict set]ting into an unnamed local variable. This requires that
* we are in a context with an LVT.
*/
nonConstant:
worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (worker < 0) {
return TCL_ERROR;
}
PushLiteral(envPtr, "", 0);
Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
TclEmitOpcode( INST_POP, envPtr);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=1 ; i<parsePtr->numWords ; i+=2) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i+1);
tokenPtr = TokenAfter(tokenPtr);
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
TclEmitInt4( worker, envPtr);
TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
Emit14Inst( INST_LOAD_SCALAR, worker, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( worker, envPtr);
return TCL_OK;
}
int
TclCompileDictMergeCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, workerIndex, infoIndex, outLoop;
/*
* Deal with some special edge cases. Note that in the case with one
* argument, the only thing to do is to verify the dict-ness.
*/
if (parsePtr->numWords < 2) {
PushLiteral(envPtr, "", 0);
return TCL_OK;
} else if (parsePtr->numWords == 2) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
return TCL_OK;
}
/*
* There's real merging work to do.
*
* Allocate some working space. This means we'll only ever compile this
* command when there's an LVT present.
*/
workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (workerIndex < 0) {
return TCL_ERROR;
}
infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
/*
* Get the first dictionary and verify that it is so.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
/*
* For each of the remaining dictionaries...
*/
outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
ExceptionRangeStarts(envPtr, outLoop);
for (i=2 ; i<parsePtr->numWords ; i++) {
/*
* Get the dictionary, and merge its pairs into the first dict (using
* a small loop).
*/
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr);
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
TclEmitInt4( workerIndex, envPtr);
TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
}
ExceptionRangeEnds(envPtr, outLoop);
TclEmitOpcode( INST_END_CATCH, envPtr);
/*
* Clean up any state left over.
*/
Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( workerIndex, envPtr);
TclEmitInstInt1( INST_JUMP1, 18, envPtr);
/*
* If an exception happens when starting to iterate over the second (and
* subsequent) dicts. This is strictly not necessary, but it is nice.
*/
ExceptionRangeTarget(envPtr, outLoop, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( workerIndex, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_RETURN_STK, envPtr);
return TCL_OK;
}
int
TclCompileDictForCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
TCL_EACH_KEEP_NONE);
}
int
TclCompileDictMapCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
TCL_EACH_COLLECT);
}
int
CompileDictEachCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Flag == TCL_EACH_COLLECT to collect and
* construct a new dictionary with the loop
* body result. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
int numVars, endTargetOffset;
int collectVar = -1; /* Index of temp var holding the result
* dict. */
int savedStackDepth = envPtr->currStackDepth;
/* Needed because jumps confuse the stack
* space calculator. */
const char **argv;
Tcl_DString buffer;
/*
|
| ︙ | ︙ | |||
809 810 811 812 813 814 815 816 817 818 819 820 821 822 |
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
dictTokenPtr = TokenAfter(varsTokenPtr);
bodyTokenPtr = TokenAfter(dictTokenPtr);
if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
/*
* Check we've got a pair of variables and that they are local variables.
* Then extract their indices in the LVT.
*/
Tcl_DStringInit(&buffer);
| > > > > > > > > > > > > > | | 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 |
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
dictTokenPtr = TokenAfter(varsTokenPtr);
bodyTokenPtr = TokenAfter(dictTokenPtr);
if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
/*
* Create temporary variable to capture return values from loop body when
* we're collecting results.
*/
if (collect == TCL_EACH_COLLECT) {
collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
envPtr);
if (collectVar < 0) {
return TCL_ERROR;
}
}
/*
* Check we've got a pair of variables and that they are local variables.
* Then extract their indices in the LVT.
*/
Tcl_DStringInit(&buffer);
TclDStringAppendToken(&buffer, &varsTokenPtr[1]);
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
&argv) != TCL_OK) {
Tcl_DStringFree(&buffer);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
if (numVars != 2) {
|
| ︙ | ︙ | |||
863 864 865 866 867 868 869 |
return TCL_ERROR;
}
/*
* Preparation complete; issue instructions. Note that this code issues
* fixed-sized jumps. That simplifies things a lot!
*
| > > > > > > > > > > | | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
return TCL_ERROR;
}
/*
* Preparation complete; issue instructions. Note that this code issues
* fixed-sized jumps. That simplifies things a lot!
*
* First up, initialize the accumulator dictionary if needed.
*/
if (collect == TCL_EACH_COLLECT) {
PushLiteral(envPtr, "", 0);
Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
/*
* Get the dictionary and start the iteration. No catching of errors at
* this point.
*/
CompileWord(envPtr, dictTokenPtr, interp, 3);
TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
emptyTargetOffset = CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
|
| ︙ | ︙ | |||
904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
/*
* Compile the loop body itself. It should be stack-neutral.
*/
SetLineInformation(3);
CompileBody(envPtr, bodyTokenPtr, interp);
TclEmitOpcode( INST_POP, envPtr);
/*
* Both exception target ranges (error and loop) end here.
*/
ExceptionRangeEnds(envPtr, loopRange);
| > > > > > > > > | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 |
/*
* Compile the loop body itself. It should be stack-neutral.
*/
SetLineInformation(3);
CompileBody(envPtr, bodyTokenPtr, interp);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitInstInt4(INST_DICT_SET, 1, envPtr);
TclEmitInt4( collectVar, envPtr);
TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
TclEmitOpcode( INST_POP, envPtr);
/*
* Both exception target ranges (error and loop) end here.
*/
ExceptionRangeEnds(envPtr, loopRange);
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
* terminated), ditching the exception info and jumping to the last
* instruction for this command. In theory, this could be done using the
* "finally" clause (next generated) but this is faster.
*/
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
| | | > > > > | | > | < > > > > > | > | 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 |
* terminated), ditching the exception info and jumping to the last
* instruction for this command. In theory, this could be done using the
* "finally" clause (next generated) but this is faster.
*/
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP4, 0, envPtr);
/*
* Error handler "finally" clause, which force-terminates the iteration
* and rethrows the error.
*/
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
if (collect == TCL_EACH_COLLECT) {
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
}
TclEmitOpcode( INST_RETURN_STK, envPtr);
/*
* Otherwise we're done (the jump after the DICT_FIRST points here) and we
* need to pop the bogus key/value pair (pushed to keep stack calculations
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
*/
envPtr->currStackDepth = savedStackDepth + 2;
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
/*
* Final stage of the command (normal case) is that we push an empty
* object (or push the accumulator as the result object). This is done
* last to promote peephole optimization when it's dropped immediately.
*/
jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
envPtr->codeStart + endTargetOffset);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
} else {
PushLiteral(envPtr, "", 0);
}
return TCL_OK;
}
int
TclCompileDictUpdateCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 |
TclEmitOpcode( INST_RETURN_STK, envPtr);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
return TCL_OK;
}
int
TclCompileDictAppendCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
| > | 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 |
TclEmitOpcode( INST_RETURN_STK, envPtr);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
int
TclCompileDictAppendCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
| ︙ | ︙ | |||
1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 |
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
PushLiteral(envPtr, "", 0);
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
PushLiteral(envPtr, "", 0);
}
}
return TCL_OK;
}
/*
* OK, we have a non-trivial body. This means that the focus is on
* generating a try-finally structure where the INST_DICT_RECOMBINE_* goes
* in the 'finally' clause.
| > | 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 |
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
PushLiteral(envPtr, "", 0);
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
PushLiteral(envPtr, "", 0);
}
}
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
/*
* OK, we have a non-trivial body. This means that the focus is on
* generating a try-finally structure where the INST_DICT_RECOMBINE_* goes
* in the 'finally' clause.
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 |
}
TclEmitOpcode( INST_RETURN_STK, envPtr);
/*
* Prepare for the start of the next command.
*/
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
return TCL_OK;
}
| > | 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 |
}
TclEmitOpcode( INST_RETURN_STK, envPtr);
/*
* Prepare for the start of the next command.
*/
envPtr->currStackDepth = savedStackDepth + 1;
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
* However, we only deal with the case where there is just a message.
*/
Tcl_Token *messageTokenPtr;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushLiteral(envPtr, "-code error -level 0", 20);
CompileWord(envPtr, messageTokenPtr, interp, 1);
TclEmitOpcode(INST_RETURN_STK, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileExprCmd --
| > > | 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
* However, we only deal with the case where there is just a message.
*/
Tcl_Token *messageTokenPtr;
int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushLiteral(envPtr, "-code error -level 0", 20);
CompileWord(envPtr, messageTokenPtr, interp, 1);
TclEmitOpcode(INST_RETURN_STK, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileExprCmd --
|
| ︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 |
TclCompileForeachCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
int firstValueTemp; /* Index of the first temp var in the frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 |
TclCompileForeachCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
TCL_EACH_KEEP_NONE);
}
/*
*----------------------------------------------------------------------
*
* CompileEachloopCmd --
*
* Procedure called to compile the "foreach" and "lmap" commands.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "foreach" command at
* runtime.
*
*----------------------------------------------------------------------
*/
static int
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. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
int firstValueTemp; /* Index of the first temp var in the frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
int collectVar = -1; /* Index of temp var holding the result var
* index. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 | /* * Lots of copying going on here. Need a ListObj wizard to show a * better way. */ Tcl_DStringInit(&varList); | | | 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 |
/*
* Lots of copying going on here. Need a ListObj wizard to show a
* better way.
*/
Tcl_DStringInit(&varList);
TclDStringAppendToken(&varList, &tokenPtr[1]);
code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
if (code != TCL_OK) {
code = TCL_ERROR;
goto done;
}
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
code = TCL_ERROR;
goto done;
}
}
loopIndex++;
}
/*
* We will compile the foreach command. Reserve (numLists + 1) temporary
* variables:
* - numLists temps to hold each value list
* - 1 temp for the loop counter (index of next element in each list)
*
* At this time we don't try to reuse temporaries; if there are two
| > > > > > > > > | 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 |
code = TCL_ERROR;
goto done;
}
}
loopIndex++;
}
if (collect == TCL_EACH_COLLECT) {
collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
envPtr);
if (collectVar < 0) {
return TCL_ERROR;
}
}
/*
* We will compile the foreach command. Reserve (numLists + 1) temporary
* variables:
* - numLists temps to hold each value list
* - 1 temp for the loop counter (index of next element in each list)
*
* At this time we don't try to reuse temporaries; if there are two
|
| ︙ | ︙ | |||
2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 |
CompileTokens(envPtr, tokenPtr, interp);
tempVar = (firstValueTemp + loopIndex);
Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
loopIndex++;
}
}
/*
* Initialize the temporary var that holds the count of loop iterations.
*/
TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr);
| > > > > > > > > > > | 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 |
CompileTokens(envPtr, tokenPtr, interp);
tempVar = (firstValueTemp + loopIndex);
Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
loopIndex++;
}
}
/*
* Create temporary variable to capture return values from loop body.
*/
if (collect == TCL_EACH_COLLECT) {
PushLiteral(envPtr, "", 0);
Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
/*
* Initialize the temporary var that holds the count of loop iterations.
*/
TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr);
|
| ︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 |
*/
SetLineInformation(bodyIndex);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode( INST_POP, envPtr);
/*
* Jump back to the test at the top of the loop. Generate a 4 byte jump if
* the distance to the test is > 120 bytes. This is conservative and
* ensures that we won't have to replace this jump if we later need to
* replace the ifFalse jump with a 4 byte jump.
| > > > > | 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 |
*/
SetLineInformation(bodyIndex);
ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr);
}
TclEmitOpcode( INST_POP, envPtr);
/*
* Jump back to the test at the top of the loop. Generate a 4 byte jump if
* the distance to the test is > 120 bytes. This is conservative and
* ensures that we won't have to replace this jump if we later need to
* replace the ifFalse jump with a 4 byte jump.
|
| ︙ | ︙ | |||
2138 2139 2140 2141 2142 2143 2144 |
/*
* Set the loop's break target.
*/
ExceptionRangeTarget(envPtr, range, breakOffset);
/*
| | > > > > > > | > | 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
/*
* Set the loop's break target.
*/
ExceptionRangeTarget(envPtr, range, breakOffset);
/*
* The command's result is an empty string if not collecting, or the
* list of results from evaluating the loop body.
*/
envPtr->currStackDepth = savedStackDepth;
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
} else {
PushLiteral(envPtr, "", 0);
}
envPtr->currStackDepth = savedStackDepth + 1;
done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
if (varvList[loopIndex] != NULL) {
ckfree(varvList[loopIndex]);
}
|
| ︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 |
}
Tcl_AppendPrintfToObj(appendObj, "%%v%u",
(unsigned) varsPtr->varIndexes[j]);
}
Tcl_AppendToObj(appendObj, "]", -1);
}
}
/*
*----------------------------------------------------------------------
*
* TclCompileGlobalCmd --
*
* Procedure called to compile the "global" command.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 |
}
Tcl_AppendPrintfToObj(appendObj, "%%v%u",
(unsigned) varsPtr->varIndexes[j]);
}
Tcl_AppendToObj(appendObj, "]", -1);
}
}
/*
*----------------------------------------------------------------------
*
* TclCompileFormatCmd --
*
* Procedure called to compile the "format" command. Handles cases that
* can be done as constants or simple string concatenation only.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "format" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
char *bytes, *start;
int i, j, len;
/*
* Don't handle any guaranteed-error cases.
*/
if (parsePtr->numWords < 2) {
return TCL_ERROR;
}
/*
* Check if the argument words are all compile-time-known literals; that's
* a case we can handle by compiling to a constant.
*/
formatObj = Tcl_NewObj();
Tcl_IncrRefCount(formatObj);
tokenPtr = TokenAfter(tokenPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
for (i=0 ; i+2 < parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
objv[i] = Tcl_NewObj();
Tcl_IncrRefCount(objv[i]);
if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
goto checkForStringConcatCase;
}
}
/*
* Everything is a literal, so the result is constant too (or an error if
* the format is broken). Do the format now.
*/
tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
parsePtr->numWords-2, objv);
for (; --i>=0 ;) {
Tcl_DecrRefCount(objv[i]);
}
ckfree(objv);
Tcl_DecrRefCount(formatObj);
if (tmpObj == NULL) {
return TCL_ERROR;
}
/*
* Not an error, always a constant result, so just push the result as a
* literal. Job done.
*/
bytes = Tcl_GetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
checkForStringConcatCase:
/*
* See if we can generate a sequence of things to concatenate. This
* requires that all the % sequences be %s or %%, as everything else is
* sufficiently complex that we don't bother.
*
* First, get the state of the system relatively sensible (cleaning up
* after our attempt to spot a literal).
*/
for (; i>=0 ; i--) {
Tcl_DecrRefCount(objv[i]);
}
ckfree(objv);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(tokenPtr);
i = 0;
/*
* Now scan through and check for non-%s and non-%% substitutions.
*/
for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
if (*bytes == '%') {
bytes++;
if (*bytes == 's') {
i++;
continue;
} else if (*bytes == '%') {
continue;
}
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
}
/*
* Check if the number of things to concatenate will fit in a byte.
*/
if (i+2 != parsePtr->numWords || i > 125) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
/*
* Generate the pushes of the things to concatenate, a sequence of
* literals and compiled tokens (of which at least one is non-literal or
* we'd have the case in the first half of this function) which we will
* concatenate.
*/
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
start = Tcl_GetString(formatObj);
/* The start of the currently-scanned literal
* in the format string. */
tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal
* being built. */
for (bytes = start ; *bytes ; bytes++) {
if (*bytes == '%') {
Tcl_AppendToObj(tmpObj, start, bytes - start);
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
char *b = Tcl_GetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
* push it and reset.
*/
if (len > 0) {
PushLiteral(envPtr, b, len);
Tcl_DecrRefCount(tmpObj);
tmpObj = Tcl_NewObj();
i++;
}
/*
* Push the code to produce the string that would be
* substituted with %s, except we'll be concatenating
* directly.
*/
CompileWord(envPtr, tokenPtr, interp, j);
tokenPtr = TokenAfter(tokenPtr);
j++;
i++;
}
start = bytes + 1;
}
}
/*
* Handle the case of a trailing literal.
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
bytes = Tcl_GetStringFromObj(tmpObj, &len);
if (len > 0) {
PushLiteral(envPtr, bytes, len);
i++;
}
Tcl_DecrRefCount(tmpObj);
Tcl_DecrRefCount(formatObj);
if (i > 1) {
/*
* Do the concatenation, which produces the result.
*/
TclEmitInstInt1(INST_CONCAT1, i, envPtr);
} else {
/*
* EVIL HACK! Force there to be a string representation in the case
* where there's just a "%s" in the format; case covered by the test
* format-20.1 (and it is horrible...)
*/
TclEmitOpcode(INST_DUP, envPtr);
PushLiteral(envPtr, "", 0);
TclEmitOpcode(INST_STR_EQ, envPtr);
TclEmitOpcode(INST_POP, envPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileGlobalCmd --
*
* Procedure called to compile the "global" command.
|
| ︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileInfo*Cmd --
*
* Procedures called to compile "info" subcommands.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "info" subcommand at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileInfoCommandsCmd(
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. */
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
char *bytes;
/*
* We require one compile-time known argument for the case we can compile.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
goto notCompilable;
}
bytes = Tcl_GetString(objPtr);
/*
* We require that the argument start with "::" and not have any of "*\[?"
* in it. (Theoretically, we should look in only the final component, but
* the difference is so slight given current naming practices.)
*/
if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
goto notCompilable;
}
Tcl_DecrRefCount(objPtr);
/*
* Confirmed as a literal that will not frighten the horses. Compile. Note
* that the result needs to be list-ified.
*/
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_STR_LEN, envPtr);
TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr);
TclEmitInstInt4( INST_LIST, 1, envPtr);
return TCL_OK;
notCompilable:
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
int
TclCompileInfoCoroutineCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [info coroutine] without arguments.
*/
if (parsePtr->numWords != 1) {
return TCL_ERROR;
}
/*
* Not much to do; we compile to a single instruction...
*/
TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
return TCL_OK;
}
int
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
|
| ︙ | ︙ | |||
2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 |
} else {
TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLappendCmd --
*
* Procedure called to compile the "lappend" command.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 |
} else {
TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
}
}
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [info level] without arguments or with a single argument.
*/
if (parsePtr->numWords == 1) {
/*
* Not much to do; we compile to a single instruction...
*/
TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
} else if (parsePtr->numWords != 2) {
return TCL_ERROR;
} else {
DefineLineInformation; /* TIP #280 */
/*
* Compile the argument, then add the instruction to convert it into a
* list of arguments.
*/
SetLineInformation(1);
CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
}
return TCL_OK;
}
int
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. */
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* We only handle [info object isa object <somevalue>]. The first three
* words are compressed to a single token by the ensemble compilation
* engine.
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
|| strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
/*
* Issue the code.
*/
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_TCLOO_NS, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLappendCmd --
*
* Procedure called to compile the "lappend" command.
|
| ︙ | ︙ | |||
3696 3697 3698 3699 3700 3701 3702 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileLmapCmd --
*
* Procedure called to compile the "lmap" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "lmap" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileLmapCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
TCL_EACH_COLLECT);
}
/*
*----------------------------------------------------------------------
*
* TclCompileNamespace*Cmd --
*
* Procedures called to compile the "namespace" command; currently, only
* the subcommands "namespace current" and "namespace upvar" are compiled
* to bytecodes, and the latter only inside a procedure(-like) context.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "namespace upvar"
* command at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileNamespaceCurrentCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [namespace current] without arguments.
*/
if (parsePtr->numWords != 1) {
return TCL_ERROR;
}
/*
* Not much to do; we compile to a single instruction...
*/
TclEmitOpcode( INST_NS_CURRENT, envPtr);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* The specification of [namespace code] is rather shocking, in that it is
* supposed to check if the argument is itself the result of [namespace
* code] and not apply itself in that case. Which is excessively cautious,
* but what the test suite checks for.
*/
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
&& strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
/*
* Technically, we could just pass a literal '::namespace inscope '
* term through, but that's something which really shouldn't be
* occurring as something that the user writes so we'll just punt it.
*/
return TCL_ERROR;
}
/*
* Now we can compile using the same strategy as [namespace code]'s normal
* implementation does internally. Note that we can't bind the namespace
* name directly here, because TclOO plays complex games with namespaces;
* the value needs to be determined at runtime for safety.
*/
PushLiteral(envPtr, "::namespace", 11);
PushLiteral(envPtr, "inscope", 7);
TclEmitOpcode( INST_NS_CURRENT, envPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitInstInt4( INST_LIST, 4, envPtr);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
DefineLineInformation; /* TIP #280 */
int off;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
PushLiteral(envPtr, "0", 1);
PushLiteral(envPtr, "::", 2);
TclEmitInstInt4( INST_OVER, 2, envPtr);
TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
off = CurrentOffset(envPtr);
PushLiteral(envPtr, "1", 1);
TclEmitOpcode( INST_SUB, envPtr);
TclEmitInstInt4( INST_OVER, 2, envPtr);
TclEmitInstInt4( INST_OVER, 1, envPtr);
TclEmitOpcode( INST_STR_INDEX, envPtr);
PushLiteral(envPtr, ":", 1);
TclEmitOpcode( INST_STR_EQ, envPtr);
off = off - CurrentOffset(envPtr);
TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr);
TclEmitOpcode( INST_STR_RANGE, envPtr);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
DefineLineInformation; /* TIP #280 */
JumpFixup jumpFixup;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
* Take care; only add 2 to found index if the string was actually found.
*/
CompileWord(envPtr, tokenPtr, interp, 1);
PushLiteral(envPtr, "::", 2);
TclEmitInstInt4( INST_OVER, 1, envPtr);
TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
TclEmitOpcode( INST_DUP, envPtr);
PushLiteral(envPtr, "0", 1);
TclEmitOpcode( INST_GE, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
PushLiteral(envPtr, "2", 1);
TclEmitOpcode( INST_ADD, envPtr);
TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
PushLiteral(envPtr, "end", 3);
TclEmitOpcode( INST_STR_RANGE, envPtr);
return TCL_OK;
}
int
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
|
| ︙ | ︙ | |||
3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 |
* Pop the namespace, and set the result to empty
*/
TclEmitOpcode( INST_POP, envPtr);
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileRegexpCmd --
*
* Procedure called to compile the "regexp" command.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 |
* Pop the namespace, and set the result to empty
*/
TclEmitOpcode( INST_POP, envPtr);
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *opt;
int idx;
if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
idx = 1;
/*
* If there's an option, check that it's "-command". We don't handle
* "-variable" (currently) and anything else is an error.
*/
if (parsePtr->numWords == 3) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
opt = tokenPtr + 1;
if (opt->size < 2 || opt->size > 8
|| strncmp(opt->start, "-command", opt->size) != 0) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
idx++;
}
/*
* Issue the bytecode.
*/
CompileWord(envPtr, tokenPtr, interp, idx);
TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileRegexpCmd --
*
* Procedure called to compile the "regexp" command.
|
| ︙ | ︙ | |||
3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileReturnCmd --
*
* Procedure called to compile the "return" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileRegsubCmd --
*
* Procedure called to compile the "regsub" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "regsub" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
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. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
/*
* We only compile the case with [regsub -all] where the pattern is both
* known at compile time and simple (i.e., no RE metacharacters). That is,
* the pattern must be translatable into a glob like "*foo*" with no other
* glob metacharacters inside it; there must be some "foo" in there too.
* The substitution string must also be known at compile time and free of
* metacharacters ("\digit" and "&"). Finally, there must not be a
* variable mentioned in the [regsub] to write the result back to (because
* we can't get the count of substitutions that would be the result in
* that case). The key is that these are the conditions under which a
* [string map] could be used instead, in particular a [string map] of the
* form we can compile to bytecode.
*
* In short, we look for:
*
* regsub -all [--] simpleRE string simpleReplacement
*
* The only optional part is the "--", and no other options are handled.
*/
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *stringTokenPtr;
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
int len, exact, result = TCL_ERROR;
if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
return TCL_ERROR;
}
/*
* Parse the "-all", which must be the first argument (other options not
* supported, non-"-all" substitution we can't compile).
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
|| strncmp(tokenPtr[1].start, "-all", 4)) {
return TCL_ERROR;
}
/*
* Get the pattern into patternObj, checking for "--" in the process.
*/
Tcl_DStringInit(&pattern);
tokenPtr = TokenAfter(tokenPtr);
patternObj = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
if (Tcl_GetString(patternObj)[0] == '-') {
if (strcmp(Tcl_GetString(patternObj), "--") != 0
|| parsePtr->numWords == 5) {
goto done;
}
tokenPtr = TokenAfter(tokenPtr);
Tcl_DecrRefCount(patternObj);
patternObj = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
} else if (parsePtr->numWords == 6) {
goto done;
}
/*
* Identify the code which produces the string to apply the substitution
* to (stringTokenPtr), and the replacement string (into replacementObj).
*/
stringTokenPtr = TokenAfter(tokenPtr);
tokenPtr = TokenAfter(stringTokenPtr);
replacementObj = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
goto done;
}
/*
* Next, higher-level checks. Is the RE a very simple glob? Is the
* replacement "simple"?
*/
bytes = Tcl_GetStringFromObj(patternObj, &len);
if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
goto done;
}
bytes = Tcl_DStringValue(&pattern);
if (*bytes++ != '*') {
goto done;
}
while (1) {
switch (*bytes) {
case '*':
if (bytes[1] == '\0') {
/*
* OK, we've proved there are no metacharacters except for the
* '*' at each end.
*/
len = Tcl_DStringLength(&pattern) - 2;
if (len > 0) {
goto isSimpleGlob;
}
/*
* The pattern is "**"! I believe that should be impossible,
* but we definitely can't handle that at all.
*/
}
case '\0': case '?': case '[': case '\\':
goto done;
}
bytes++;
}
isSimpleGlob:
for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
switch (*bytes) {
case '\\': case '&':
goto done;
}
}
/*
* Proved the simplicity constraints! Time to issue the code.
*/
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
Tcl_DStringFree(&pattern);
if (patternObj) {
Tcl_DecrRefCount(patternObj);
}
if (replacementObj) {
Tcl_DecrRefCount(replacementObj);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclCompileReturnCmd --
*
* Procedure called to compile the "return" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
|
| ︙ | ︙ | |||
3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 |
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, size, status = TCL_OK;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
DefineLineInformation; /* TIP #280 */
/*
* Check for special case which can always be compiled:
* return -options <opts> <msg>
| > | 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 |
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, size, status = TCL_OK;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
int savedStackDepth = envPtr->currStackDepth;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
DefineLineInformation; /* TIP #280 */
/*
* Check for special case which can always be compiled:
* return -options <opts> <msg>
|
| ︙ | ︙ | |||
3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 |
&& (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
CompileWord(envPtr, optsTokenPtr, interp, 2);
CompileWord(envPtr, msgTokenPtr, interp, 3);
TclEmitOpcode(INST_RETURN_STK, envPtr);
return TCL_OK;
}
/*
* Allocate some working space.
*/
| > | 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 |
&& (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
CompileWord(envPtr, optsTokenPtr, interp, 2);
CompileWord(envPtr, msgTokenPtr, interp, 3);
TclEmitOpcode(INST_RETURN_STK, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
/*
* Allocate some working space.
*/
|
| ︙ | ︙ | |||
4294 4295 4296 4297 4298 4299 4300 |
}
/*
* Loop over the (var, value) pairs.
*/
valueTokenPtr = parsePtr->tokenPtr;
| | | | | | 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 |
}
/*
* Loop over the (var, value) pairs.
*/
valueTokenPtr = parsePtr->tokenPtr;
for (i=1; i<numWords; i+=2) {
varTokenPtr = TokenAfter(valueTokenPtr);
valueTokenPtr = TokenAfter(varTokenPtr);
localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
if (localIndex < 0) {
return TCL_ERROR;
}
CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
if (i+1 < numWords) {
/*
* A value has been given: set the variable, pop the value
*/
CompileWord(envPtr, valueTokenPtr, interp, i+1);
Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
}
/*
* Set the result to empty
|
| ︙ | ︙ | |||
4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 |
tailName = p;
}
localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
Tcl_DecrRefCount(tailPtr);
return localIndex;
}
/*
*----------------------------------------------------------------------
*
* PushVarName --
*
* Procedure used in the compiling where pushing a variable name is
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 |
tailName = p;
}
localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
Tcl_DecrRefCount(tailPtr);
return localIndex;
}
int
TclCompileObjectSelfCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* We only handle [self] and [self object] (which is the same operation).
* These are the only very common operations on [self] for which
* bytecoding is at all reasonable.
*/
if (parsePtr->numWords == 1) {
goto compileSelfObject;
} else if (parsePtr->numWords == 2) {
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
return TCL_ERROR;
}
subcmd = tokenPtr + 1;
if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
goto compileSelfObject;
} else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
goto compileSelfNamespace;
}
}
/*
* Can't compile; handle with runtime call.
*/
return TCL_ERROR;
compileSelfObject:
/*
* This delegates the entire problem to a single opcode.
*/
TclEmitOpcode( INST_TCLOO_SELF, envPtr);
return TCL_OK;
compileSelfNamespace:
/*
* This is formally only correct with TclOO methods as they are currently
* implemented; it assumes that the current namespace is invariably when a
* TclOO context is present is the object's namespace, and that's
* technically only something that's a matter of current policy. But it
* avoids creating another opcode, so that's all good!
*/
TclEmitOpcode( INST_TCLOO_SELF, envPtr);
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_NS_CURRENT, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* PushVarName --
*
* Procedure used in the compiling where pushing a variable name is
|
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 |
*/
static int
PushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
| | | 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 |
*/
static int
PushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *simpleVarNamePtr, /* Must not be NULL. */
int *isScalarPtr, /* Must not be NULL. */
int line, /* Line the token starts on. */
int *clNext) /* Reference to offset of next hidden cont.
* line. */
{
|
| ︙ | ︙ | |||
4627 4628 4629 4630 4631 4632 4633 |
}
}
if (localIndex < 0) {
PushLiteral(envPtr, name, nameChars);
}
/*
| | > | | 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 |
}
}
if (localIndex < 0) {
PushLiteral(envPtr, name, nameChars);
}
/*
* Compile the element script, if any, and only if not inhibited. [Bug
* 3600328]
*/
if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameChars) {
envPtr->line = line;
envPtr->clNext = clNext;
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
envPtr);
} else {
PushLiteral(envPtr, "", 0);
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
/*
* Shorthand macros for instruction issuing.
*/
#define OP(name) TclEmitOpcode(INST_##name, envPtr)
#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr)
#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define BODY(token,index) \
SetLineInformation((index));CompileBody(envPtr,(token),interp)
#define PUSH(str) \
PushLiteral(envPtr,(str),strlen(str))
#define JUMP(var,name) \
| > > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
/*
* Shorthand macros for instruction issuing.
*/
#define OP(name) TclEmitOpcode(INST_##name, envPtr)
#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr)
#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr)
#define OP14(name,val1,val2) \
TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define BODY(token,index) \
SetLineInformation((index));CompileBody(envPtr,(token),interp)
#define PUSH(str) \
PushLiteral(envPtr,(str),strlen(str))
#define JUMP(var,name) \
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileString*Cmd --
*
* Procedures called to compile various subcommands of the "string"
* command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "string" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 |
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_CMP, envPtr);
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_CMP, envPtr);
return TCL_OK;
}
int
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
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 |
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_EQ, envPtr);
return TCL_OK;
}
| | > > > > > > > > > > > > | < > | | > > > | < < > > | | > | > > > | > | > > > > > > | | > > > | > > > | > > > | > > | > > > > > > > > | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_EQ, envPtr);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
/*
* Push the two operands onto the stack and then the test.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
OP(STR_FIND);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
/*
* Push the two operands onto the stack and then the test.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
OP(STR_FIND_LAST);
return TCL_OK;
}
int
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
|
| ︙ | ︙ | |||
390 391 392 393 394 395 396 |
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_INDEX, envPtr);
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
TclEmitOpcode(INST_STR_INDEX, envPtr);
return TCL_OK;
}
int
TclCompileStringMatchCmd(
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
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 |
if (exactMatch) {
TclEmitOpcode(INST_STR_EQ, envPtr);
} else {
TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
}
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
if (exactMatch) {
TclEmitOpcode(INST_STR_EQ, envPtr);
} else {
TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
}
return TCL_OK;
}
int
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
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
SetLineInformation(1);
CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_STR_LEN, envPtr);
}
TclDecrRefCount(objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
*
* Procedure called to compile the "subst" command.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
SetLineInformation(1);
CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_STR_LEN, envPtr);
}
TclDecrRefCount(objPtr);
return TCL_OK;
}
int
TclCompileStringMapCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
char *bytes;
int len;
/*
* We only handle the case:
*
* string map {foo bar} $thing
*
* That is, a literal two-element list (doesn't need to be brace-quoted,
* but does need to be compile-time knowable) and any old argument (the
* thing to map).
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
mapObj = Tcl_NewObj();
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TCL_ERROR;
} else if (len != 2) {
Tcl_DecrRefCount(mapObj);
return TCL_ERROR;
}
/*
* Now issue the opcodes. Note that in the case that we know that the
* first word is an empty word, we don't issue the map at all. That is the
* correct semantics for mapping.
*/
bytes = Tcl_GetStringFromObj(objv[0], &len);
if (len == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(objv[1], &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
}
Tcl_DecrRefCount(mapObj);
return TCL_OK;
}
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
Tcl_Obj *tmpObj;
int idx1, idx2, result;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
stringTokenPtr = TokenAfter(parsePtr->tokenPtr);
fromTokenPtr = TokenAfter(stringTokenPtr);
toTokenPtr = TokenAfter(fromTokenPtr);
/*
* Parse the first index. Will only compile if it is constant and not an
* _integer_ less than zero (since we reserve negative indices here for
* end-relative indexing).
*/
tmpObj = Tcl_NewObj();
result = TCL_ERROR;
if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) {
if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) {
if (idx1 >= 0) {
result = TCL_OK;
}
} else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) {
if (idx1 <= -2) {
result = TCL_OK;
}
}
}
TclDecrRefCount(tmpObj);
if (result != TCL_OK) {
goto nonConstantIndices;
}
/*
* Parse the second index. Will only compile if it is constant and not an
* _integer_ less than zero (since we reserve negative indices here for
* end-relative indexing).
*/
tmpObj = Tcl_NewObj();
result = TCL_ERROR;
if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) {
if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) {
if (idx2 >= 0) {
result = TCL_OK;
}
} else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) {
if (idx2 <= -2) {
result = TCL_OK;
}
}
}
TclDecrRefCount(tmpObj);
if (result != TCL_OK) {
goto nonConstantIndices;
}
/*
* Push the operand onto the stack and then the substring operation.
*/
CompileWord(envPtr, stringTokenPtr, interp, 1);
OP44( STR_RANGE_IMM, idx1, idx2);
return TCL_OK;
/*
* Push the operands onto the stack and then the substring operation.
*/
nonConstantIndices:
CompileWord(envPtr, stringTokenPtr, interp, 1);
CompileWord(envPtr, fromTokenPtr, interp, 2);
CompileWord(envPtr, toTokenPtr, interp, 3);
OP( STR_RANGE);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
*
* Procedure called to compile the "subst" command.
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); literal = TclRegisterNewLiteral(envPtr, buf, length); TclEmitPush(literal, envPtr); count++; continue; | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | < | | > | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 |
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buf);
literal = TclRegisterNewLiteral(envPtr, buf, length);
TclEmitPush(literal, envPtr);
count++;
continue;
case TCL_TOKEN_VARIABLE:
/*
* Check for simple variable access; see if we can only generate
* TCL_OK or TCL_ERROR from the substituted variable read; if so,
* there is no need to generate elaborate exception-management
* code. Note that the first component of TCL_TOKEN_VARIABLE is
* always TCL_TOKEN_TEXT...
*/
if (tokenPtr->numComponents > 1) {
int i, foundCommand = 0;
for (i=2 ; i<=tokenPtr->numComponents ; i++) {
if (tokenPtr[i].type == TCL_TOKEN_COMMAND) {
foundCommand = 1;
break;
}
}
if (foundCommand) {
break;
}
}
envPtr->line = bline;
TclCompileVarSubst(interp, tokenPtr, envPtr);
bline = envPtr->line;
count++;
continue;
}
while (count > 255) {
OP1( CONCAT1, 255);
count -= 254;
}
if (count > 1) {
OP1( CONCAT1, count);
count = 1;
}
if (breakOffset == 0) {
/* Jump to the start (jump over the jump to end) */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup);
/* Jump to the end (all BREAKs land here) */
breakOffset = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
/* Start */
if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d",
(int) (CurrentOffset(envPtr) - startFixup.codeOffset));
}
}
envPtr->line = bline;
catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
OP4( BEGIN_CATCH4, catchRange);
ExceptionRangeStarts(envPtr, catchRange);
switch (tokenPtr->type) {
case TCL_TOKEN_COMMAND:
TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2,
envPtr);
count++;
break;
case TCL_TOKEN_VARIABLE:
TclCompileVarSubst(interp, tokenPtr, envPtr);
count++;
break;
default:
Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d",
tokenPtr->type);
}
ExceptionRangeEnds(envPtr, catchRange);
/* Substitution produced TCL_OK */
OP( END_CATCH);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
/* Exceptional return codes processed here */
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
OP( PUSH_RETURN_OPTIONS);
OP( PUSH_RESULT);
OP( PUSH_RETURN_CODE);
OP( END_CATCH);
OP( RETURN_CODE_BRANCH);
/* ERROR -> reraise it */
OP( RETURN_STK);
OP( NOP);
/* RETURN */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
/* BREAK */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup);
/* CONTINUE */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup);
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
(int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
}
OP( POP);
OP( POP);
breakJump = CurrentOffset(envPtr) - breakOffset;
if (breakJump > 127) {
OP4(JUMP4, -breakJump);
} else {
OP1(JUMP1, -breakJump);
}
/* CONTINUE destination */
if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
(int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
}
OP( POP);
OP( POP);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
/* RETURN + other destination */
if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
(int) (CurrentOffset(envPtr) - returnFixup.codeOffset));
}
if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d",
(int) (CurrentOffset(envPtr) - otherFixup.codeOffset));
}
/*
* Pull the result to top of stack, discard options dict.
*/
OP4( REVERSE, 2);
OP( POP);
/*
* We've emitted several POP instructions, and the automatic
* computations for stack depth requirements have been decrementing
* for every one. However, we know that every branch actually taken
* only encounters some of those instructions. No branch passes
* through them all. So, we now have a stack requirements estimate
* that is too low. Here we manually fix that up.
*/
TclAdjustStackDepth(5, envPtr);
/* OK destination */
if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d",
(int) (CurrentOffset(envPtr) - okFixup.codeOffset));
}
if (count > 1) {
OP1(CONCAT1, count);
count = 1;
}
/* CONTINUE jump to here */
if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d",
(int) (CurrentOffset(envPtr) - endFixup.codeOffset));
}
bline = envPtr->line;
}
while (count > 255) {
OP1( CONCAT1, 255);
count -= 254;
}
if (count > 1) {
OP1( CONCAT1, count);
}
Tcl_FreeParse(&parse);
if (state != NULL) {
Tcl_RestoreInterpState(interp, state);
TclCompileSyntaxError(interp, envPtr);
TclAdjustStackDepth(-1, envPtr);
}
/* Final target of the multi-jump from all BREAKs */
if (breakOffset > 0) {
TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset,
envPtr->codeStart + breakOffset);
}
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
while (numBytes > 0) {
const char *prevBytes = bytes;
int literal;
if (TCL_OK != TclFindElement(NULL, bytes, numBytes,
&(bodyTokenArray[numWords].start), &bytes,
&(bodyTokenArray[numWords].size), &literal) || !literal) {
| | < < < < < | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
while (numBytes > 0) {
const char *prevBytes = bytes;
int literal;
if (TCL_OK != TclFindElement(NULL, bytes, numBytes,
&(bodyTokenArray[numWords].start), &bytes,
&(bodyTokenArray[numWords].size), &literal) || !literal) {
goto abort;
}
bodyTokenArray[numWords].type = TCL_TOKEN_TEXT;
bodyTokenArray[numWords].numComponents = 0;
bodyToken[numWords] = bodyTokenArray + numWords;
/*
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes);
TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source);
numBytes -= (bytes - prevBytes);
numWords++;
}
if (numWords % 2) {
| | > > > > > | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 |
TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes);
TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source);
numBytes -= (bytes - prevBytes);
numWords++;
}
if (numWords % 2) {
abort:
ckfree((char *) bodyToken);
ckfree((char *) bodyTokenArray);
ckfree((char *) bodyLines);
ckfree((char *) bodyContLines);
return TCL_ERROR;
}
} else if (numWords % 2 || numWords == 0) {
/*
* Odd number of words (>1) available, or no words at all available.
* Both are error cases, so punt and let the interpreted-version
* generate the error message. Note that the second case probably
* should get caught earlier, but it's easy to check here again anyway
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 |
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
* Generate the test for the arm.
*/
switch (mode) {
case Switch_Exact:
| | | | | | 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
* Generate the test for the arm.
*/
switch (mode) {
case Switch_Exact:
OP( DUP);
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
OP( STR_EQ);
break;
case Switch_Glob:
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
OP4( OVER, 1);
OP1( STR_MATCH, noCase);
break;
case Switch_Regexp:
simple = exact = 0;
/*
* Keep in sync with TclCompileRegexpCmd.
*/
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 |
Tcl_DStringFree(&ds);
}
}
if (!simple) {
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
}
| | | | | | 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
Tcl_DStringFree(&ds);
}
}
if (!simple) {
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
}
OP4( OVER, 1);
if (!simple) {
/*
* Pass correct RE compile flags. We use only Int1
* (8-bit), but that handles all the flags we want to
* pass. Don't use TCL_REG_NOSUB as we may have backrefs
* or capture vars.
*/
int cflags = TCL_REG_ADVANCED
| (noCase ? TCL_REG_NOCASE : 0);
OP1(REGEXP, cflags);
} else if (exact && !noCase) {
OP( STR_EQ);
} else {
OP1(STR_MATCH, noCase);
}
break;
default:
Tcl_Panic("unknown switch mode: %d", mode);
}
/*
|
| ︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 | /* * Now do the actual compilation. Note that we do not use CompileBody * because we may have synthesized the tokens in a non-standard * pattern. */ | | | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 |
/*
* Now do the actual compilation. Note that we do not use CompileBody
* because we may have synthesized the tokens in a non-standard
* pattern.
*/
OP( POP);
envPtr->currStackDepth = savedStackDepth + 1;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
if (!foundDefault) {
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
|
| ︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 |
* Discard the value we are matching against unless we've had a default
* clause (in which case it will already be gone due to the code at the
* start of processing an arm, guaranteed) and make the result of the
* command an empty string.
*/
if (!foundDefault) {
| | | 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 |
* Discard the value we are matching against unless we've had a default
* clause (in which case it will already be gone due to the code at the
* start of processing an arm, guaranteed) and make the result of the
* command an empty string.
*/
if (!foundDefault) {
OP( POP);
PushLiteral(envPtr, "", 0);
}
/*
* Do jump fixups for arms that were executed. First, fill in the jumps of
* all jumps that don't point elsewhere to point to here.
*/
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 |
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
Tcl_HashEntry *hPtr;
/*
* First, we push the value we're matching against on the stack.
| > | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
int savedStackDepth = envPtr->currStackDepth;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
Tcl_HashEntry *hPtr;
/*
* First, we push the value we're matching against on the stack.
|
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 |
* the "default" default, which just sets the result to empty). Note that
* we will come back and rewrite the jump's offset parameter when we know
* what it should be, and that all jumps we issue are of the wide kind
* because that makes the code much easier to debug!
*/
jumpLocation = CurrentOffset(envPtr);
| | | | < | 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 |
* the "default" default, which just sets the result to empty). Note that
* we will come back and rewrite the jump's offset parameter when we know
* what it should be, and that all jumps we issue are of the wide kind
* because that makes the code much easier to debug!
*/
jumpLocation = CurrentOffset(envPtr);
OP4( JUMP_TABLE, infoIndex);
jumpToDefault = CurrentOffset(envPtr);
OP4( JUMP4, 0);
for (i=0 ; i<numBodyTokens ; i+=2) {
/*
* For each arm, we must first work out what to do with the match
* term.
*/
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
* This is not a default clause, so insert the current location as
* a target in the jump table (assuming it isn't already there,
* which would indicate that this clause is probably masked by an
* earlier one). Note that we use a Tcl_DString here simply
* because the hash API does not let us specify the string length.
*/
Tcl_DStringInit(&buffer);
TclDStringAppendToken(&buffer, bodyToken[i]);
hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
Tcl_DStringValue(&buffer), &isNew);
if (isNew) {
/*
* First time we've encountered this match clause, so it must
* point to here.
*/
|
| ︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 |
}
mustGenerate = 0;
/*
* Compile the body of the arm.
*/
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
/*
* Compile a jump in to the end of the command if this body is
* anything other than a user-supplied default arm (to either skip
* over the remaining bodies or the code that generates an empty
* result).
*/
if (i+2 < numBodyTokens || !foundDefault) {
finalFixups[numRealBodies++] = CurrentOffset(envPtr);
/*
* Easier by far to issue this jump as a fixed-width jump, since
* otherwise we'd need to do a lot more (and more awkward)
* rewriting when we fixed this all up.
*/
| > | > > | 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 |
}
mustGenerate = 0;
/*
* Compile the body of the arm.
*/
envPtr->currStackDepth = savedStackDepth;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
/*
* Compile a jump in to the end of the command if this body is
* anything other than a user-supplied default arm (to either skip
* over the remaining bodies or the code that generates an empty
* result).
*/
if (i+2 < numBodyTokens || !foundDefault) {
finalFixups[numRealBodies++] = CurrentOffset(envPtr);
/*
* Easier by far to issue this jump as a fixed-width jump, since
* otherwise we'd need to do a lot more (and more awkward)
* rewriting when we fixed this all up.
*/
OP4( JUMP4, 0);
}
}
/*
* We're at the end. If we've not already done so through the processing
* of a user-supplied default clause, add in a "default" default clause
* now.
*/
if (!foundDefault) {
envPtr->currStackDepth = savedStackDepth;
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
envPtr->codeStart+jumpToDefault+1);
PushLiteral(envPtr, "", 0);
}
/*
* No more instructions to be issued; everything that needs to jump to the
* end of the command is fixed up at this point.
*/
for (i=0 ; i<numRealBodies ; i++) {
TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
envPtr->codeStart+finalFixups[i]+1);
}
/*
* Clean up all our temporary space and return.
*/
TclStackFree(interp, finalFixups);
envPtr->currStackDepth = savedStackDepth + 1;
}
/*
*----------------------------------------------------------------------
*
* DupJumptableInfo, FreeJumptableInfo --
*
|
| ︙ | ︙ | |||
1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 |
keyPtr, pcOffset + offset);
}
}
/*
*----------------------------------------------------------------------
*
* TclCompileThrowCmd --
*
* Procedure called to compile the "throw" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 |
keyPtr, pcOffset + offset);
}
}
/*
*----------------------------------------------------------------------
*
* TclCompileTailcallCmd --
*
* Procedure called to compile the "tailcall" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "tailcall" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords < 2 || parsePtr->numWords > 256
|| envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/* make room for the nsObjPtr */
CompileWord(envPtr, tokenPtr, interp, 0);
for (i=1 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileThrowCmd --
*
* Procedure called to compile the "throw" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 |
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
if (numWords != 3) {
return TCL_ERROR;
}
codeToken = TokenAfter(parsePtr->tokenPtr);
| > | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
int savedStackDepth = envPtr->currStackDepth;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
if (numWords != 3) {
return TCL_ERROR;
}
codeToken = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 |
* Must still do this; might generate an error when getting this
* "ignored" value prepared as an argument.
*/
CompileWord(envPtr, msgToken, interp, 2);
TclCompileSyntaxError(interp, envPtr);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
if (len == 0) {
/*
* Must still do this; might generate an error when getting this
* "ignored" value prepared as an argument.
*/
CompileWord(envPtr, msgToken, interp, 2);
goto issueErrorForEmptyCode;
}
TclNewLiteralStringObj(errPtr, "-errorcode");
TclNewObj(dictPtr);
Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr);
Tcl_IncrRefCount(dictPtr);
string = Tcl_GetStringFromObj(dictPtr, &len);
CompileWord(envPtr, msgToken, interp, 2);
PushLiteral(envPtr, string, len);
TclDecrRefCount(dictPtr);
OP44( RETURN_IMM, 1, 0);
} else {
/*
* When the code token is not known at compilation time, we need to do
* a little bit more work. The main tricky bit here is that the error
* code has to be a list (a [throw] restriction) so we must emit extra
* instructions to enforce that condition.
*/
| > > | 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 |
* Must still do this; might generate an error when getting this
* "ignored" value prepared as an argument.
*/
CompileWord(envPtr, msgToken, interp, 2);
TclCompileSyntaxError(interp, envPtr);
Tcl_DecrRefCount(objPtr);
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
if (len == 0) {
/*
* Must still do this; might generate an error when getting this
* "ignored" value prepared as an argument.
*/
CompileWord(envPtr, msgToken, interp, 2);
goto issueErrorForEmptyCode;
}
TclNewLiteralStringObj(errPtr, "-errorcode");
TclNewObj(dictPtr);
Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr);
Tcl_IncrRefCount(dictPtr);
string = Tcl_GetStringFromObj(dictPtr, &len);
CompileWord(envPtr, msgToken, interp, 2);
PushLiteral(envPtr, string, len);
TclDecrRefCount(dictPtr);
OP44( RETURN_IMM, 1, 0);
envPtr->currStackDepth = savedStackDepth + 1;
} else {
/*
* When the code token is not known at compilation time, we need to do
* a little bit more work. The main tricky bit here is that the error
* code has to be a list (a [throw] restriction) so we must emit extra
* instructions to enforce that condition.
*/
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 |
*/
issueErrorForEmptyCode:
PUSH( "type must be non-empty list");
PUSH( "");
OP44( RETURN_IMM, 1, 0);
}
TclDecrRefCount(objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| > | 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 |
*/
issueErrorForEmptyCode:
PUSH( "type must be non-empty list");
PUSH( "");
OP44( RETURN_IMM, 1, 0);
}
envPtr->currStackDepth = savedStackDepth + 1;
TclDecrRefCount(objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 |
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, len, forwardsNeedFixing = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (resultVar < 0 || optionsVar < 0) {
| > | 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 |
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int savedStackDepth = envPtr->currStackDepth;
int i, j, len, forwardsNeedFixing = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (resultVar < 0 || optionsVar < 0) {
|
| ︙ | ︙ | |||
2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 |
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
JUMP(notECJumpSource, JUMP_FALSE4);
} else {
notECJumpSource = -1; /* LINT */
}
| > | 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 |
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
JUMP(notECJumpSource, JUMP_FALSE4);
} else {
notECJumpSource = -1; /* LINT */
}
|
| ︙ | ︙ | |||
2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 |
if (forwardsToFix[j] == -1) {
continue;
}
FIXJUMP(forwardsToFix[j]);
forwardsToFix[j] = -1;
}
}
BODY( handlerTokens[i], 5+i*4);
}
JUMP(addrsToFix[i], JUMP4);
if (matchClauses[i]) {
FIXJUMP(notECJumpSource);
}
| > | 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 |
if (forwardsToFix[j] == -1) {
continue;
}
FIXJUMP(forwardsToFix[j]);
forwardsToFix[j] = -1;
}
}
envPtr->currStackDepth = savedStackDepth;
BODY( handlerTokens[i], 5+i*4);
}
JUMP(addrsToFix[i], JUMP4);
if (matchClauses[i]) {
FIXJUMP(notECJumpSource);
}
|
| ︙ | ︙ | |||
2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 |
*/
for (i=0 ; i<numHandlers ; i++) {
FIXJUMP(addrsToFix[i]);
}
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
return TCL_OK;
}
static int
IssueTryFinallyInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
| > | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 |
*/
for (i=0 ; i<numHandlers ; i++) {
FIXJUMP(addrsToFix[i]);
}
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
static int
IssueTryFinallyInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
|
| ︙ | ︙ | |||
2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 |
* Compile the body, trapping any error in it so that we can trap on it
* (if any trap matches) and run a finally clause.
*/
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
PUSH( "0");
OP4( REVERSE, 2);
OP1( JUMP1, 4);
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
| > | 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 |
* Compile the body, trapping any error in it so that we can trap on it
* (if any trap matches) and run a finally clause.
*/
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
envPtr->currStackDepth = savedStackDepth;
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
PUSH( "0");
OP4( REVERSE, 2);
OP1( JUMP1, 4);
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 |
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
JUMP(notECJumpSource, JUMP_FALSE4);
} else {
notECJumpSource = -1; /* LINT */
}
| > | 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 |
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
JUMP(notECJumpSource, JUMP_FALSE4);
} else {
notECJumpSource = -1; /* LINT */
}
|
| ︙ | ︙ | |||
2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 | continue; } FIXJUMP(forwardsToFix[j]); forwardsToFix[j] = -1; } OP4( BEGIN_CATCH4, range); } BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); OP( PUSH_RETURN_OPTIONS); OP4( REVERSE, 2); OP1( JUMP1, 4); forwardsToFix[i] = -1; | > | 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 | continue; } FIXJUMP(forwardsToFix[j]); forwardsToFix[j] = -1; } OP4( BEGIN_CATCH4, range); } envPtr->currStackDepth = savedStackDepth; BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); OP( PUSH_RETURN_OPTIONS); OP4( REVERSE, 2); OP1( JUMP1, 4); forwardsToFix[i] = -1; |
| ︙ | ︙ | |||
2449 2450 2451 2452 2453 2454 2455 |
}
/*
* Drop the result code.
*/
OP( POP);
| < > > | 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 |
}
/*
* Drop the result code.
*/
OP( POP);
/*
* Process the finally clause (at last!) Note that we do not wrap this in
* error handlers because we would just rethrow immediately anyway. Then
* (on normal success) we reissue the exception. Note also that
* INST_RETURN_STK can proceed to the next instruction; that'll be the
* next command (or some inter-command manipulation).
*/
envPtr->currStackDepth = savedStackDepth;
BODY( finallyToken, 3 + 4*numHandlers);
OP( POP);
LOAD( optionsVar);
LOAD( resultVar);
OP( RETURN_STK);
envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 |
Tcl_Obj *leadingWord;
DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords-1;
flags = 1;
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
leadingWord = Tcl_NewObj();
| | | 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 |
Tcl_Obj *leadingWord;
DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords-1;
flags = 1;
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
leadingWord = Tcl_NewObj();
if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
int len;
const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
varTokenPtr = TokenAfter(varTokenPtr);
numWords--;
|
| ︙ | ︙ | |||
2544 2545 2546 2547 2548 2549 2550 |
&localIndex, &simpleVarName, &isScalar, 1);
/*
* Emit instructions to unset the variable.
*/
if (!simpleVarName) {
| | | | < | | < | 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 |
&localIndex, &simpleVarName, &isScalar, 1);
/*
* Emit instructions to unset the variable.
*/
if (!simpleVarName) {
OP1( UNSET_STK, flags);
} else if (isScalar) {
if (localIndex < 0) {
OP1( UNSET_STK, flags);
} else {
OP14( UNSET_SCALAR, flags, localIndex);
}
} else {
if (localIndex < 0) {
OP1( UNSET_ARRAY_STK, flags);
} else {
OP14( UNSET_ARRAY, flags, localIndex);
}
}
varTokenPtr = TokenAfter(varTokenPtr);
}
PushLiteral(envPtr, "", 0);
return TCL_OK;
|
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 |
*/
SetLineInformation(2);
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
| | | 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 |
*/
SetLineInformation(2);
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
OP( POP);
/*
* Compile the test expression then emit the conditional jump that
* terminates the while. We already know it's a simple word.
*/
if (loopMayEnd) {
|
| ︙ | ︙ | |||
2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 |
*/
pushResult:
envPtr->currStackDepth = savedStackDepth;
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* PushVarName --
*
* Procedure used in the compiling where pushing a variable name is
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 |
*/
pushResult:
envPtr->currStackDepth = savedStackDepth;
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileYieldCmd --
*
* Procedure called to compile the "yield" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "yield" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
return TCL_ERROR;
}
if (parsePtr->numWords == 1) {
PushLiteral(envPtr, "", 0);
} else {
DefineLineInformation; /* TIP #280 */
Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 1);
}
OP( YIELD);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* PushVarName --
*
* Procedure used in the compiling where pushing a variable name is
|
| ︙ | ︙ | |||
3071 3072 3073 3074 3075 3076 3077 |
}
if (words > 3) {
/*
* Reverse order of arguments to get precise agreement with [expr] in
* calcuations, including roundoff errors.
*/
| | | 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 |
}
if (words > 3) {
/*
* Reverse order of arguments to get precise agreement with [expr] in
* calcuations, including roundoff errors.
*/
OP4( REVERSE, words-1);
}
while (--words > 1) {
TclEmitOpcode(instruction, envPtr);
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
3162 3163 3164 3165 3166 3167 3168 | int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); | | < < < < | < < < < | < < < < | < | < < < < < | 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 |
int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
int words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
STORE(tmpIndex);
TclEmitOpcode(instruction, envPtr);
for (words=3 ; words<parsePtr->numWords ;) {
LOAD(tmpIndex);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
if (++words < parsePtr->numWords) {
STORE(tmpIndex);
}
TclEmitOpcode(instruction, envPtr);
}
for (; words>3 ; words--) {
OP( BITAND);
}
/*
* Drop the value from the temp variable; retaining that reference
* might be expensive elsewhere.
*/
OP14( UNSET_SCALAR, 0, tmpIndex);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
2292 2293 2294 2295 2296 2297 2298 |
switch (nodePtr->lexeme) {
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
int length;
Tcl_DStringInit(&cmdName);
| | | 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 |
switch (nodePtr->lexeme) {
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
int length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
Tcl_DStringValue(&cmdName),
Tcl_DStringLength(&cmdName)), envPtr);
Tcl_DStringFree(&cmdName);
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | * This variable is linked to the Tcl variable "tcl_traceCompile". */ #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | * This variable is linked to the Tcl variable "tcl_traceCompile". */ #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The * names "op1" and "op4" refer to an instruction's one or four byte first * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to * topmost stack elements. * |
| ︙ | ︙ | |||
368 369 370 371 372 373 374 |
{"jumpTable", 5, -1, 1, {OPERAND_AUX4}},
/* Jump according to the jump-table (in AuxData as indicated by the
* operand) and the argument popped from the list. Always executes the
* next instruction if no match against the table's entries was found.
* Stack: ... value => ...
* Note that the jump table contains offsets relative to the PC when
* it points to this instruction; the code is relocatable. */
| | | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
{"jumpTable", 5, -1, 1, {OPERAND_AUX4}},
/* Jump according to the jump-table (in AuxData as indicated by the
* operand) and the argument popped from the list. Always executes the
* next instruction if no match against the table's entries was found.
* Stack: ... value => ...
* Note that the jump table contains offsets relative to the PC when
* it points to this instruction; the code is relocatable. */
{"upvar", 5, -1, 1, {OPERAND_LVT4}},
/* finds level and otherName in stack, links to local variable at
* index op1. Leaves the level on stack. */
{"nsupvar", 5, -1, 1, {OPERAND_LVT4}},
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"variable", 5, -1, 1, {OPERAND_LVT4}},
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
/* Compiled bytecodes to signal syntax error. */
{"reverse", 5, 0, 1, {OPERAND_UINT4}},
/* Reverse the order of the arg elements at the top of stack */
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
/* Map variable contents back into a dictionary in a variable. Part of
* [dict with].
* Stack: ... dictVarName path keyList => ... */
{"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}},
/* Map variable contents back into a dictionary in the local variable
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
/* Map variable contents back into a dictionary in a variable. Part of
* [dict with].
* Stack: ... dictVarName path keyList => ... */
{"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}},
/* Map variable contents back into a dictionary in the local variable
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
{"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* The top 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 a
* boolean indicating whether it is possible to read out a value from
* that key-path (like [dict exists]).
* Stack: ... dict key1 ... keyN => ... boolean */
{"verifyDict", 1, -1, 0, {OPERAND_NONE}},
/* Verifies that the word on the top of the stack is a dictionary,
* popping it if it is and throwing an error if it is not.
* Stack: ... value => ... */
{"strmap", 1, -2, 0, {OPERAND_NONE}},
/* Simplified version of [string map] that only applies one change
* string, and only case-sensitively.
* Stack: ... from to string => ... changedString */
{"strfind", 1, -1, 0, {OPERAND_NONE}},
/* Find the first index of a needle string in a haystack string,
* producing the index (integer) or -1 if nothing found.
* Stack: ... needle haystack => ... index */
{"strrfind", 1, -1, 0, {OPERAND_NONE}},
/* Find the last index of a needle string in a haystack string,
* producing the index (integer) or -1 if nothing found.
* Stack: ... needle haystack => ... index */
{"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}},
/* String Range: push (string range stktop op4 op4) */
{"strrange", 1, -2, 0, {OPERAND_NONE}},
/* String Range with non-constant arguments.
* Stack: ... string idxA idxB => ... substring */
{"yield", 1, 0, 0, {OPERAND_NONE}},
/* Makes the current coroutine yield the value at the top of the
* stack, and places the response back on top of the stack when it
* resumes.
* Stack: ... valueToYield => ... resumeValue */
{"coroName", 1, +1, 0, {OPERAND_NONE}},
/* Push the name of the interpreter's current coroutine as an object
* on the stack. */
{"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Do a tailcall with the opnd items on the stack as the thing to
* tailcall to; opnd must be greater than 0 for the semantics to work
* right. */
{"currentNamespace", 1, +1, 0, {OPERAND_NONE}},
/* Push the name of the interpreter's current namespace as an object
* on the stack. */
{"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}},
/* Push the stack depth (i.e., [info level]) of the interpreter as an
* object on the stack. */
{"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}},
/* Push the argument words to a stack depth (i.e., [info level <n>])
* of the interpreter as an object on the stack.
* Stack: ... depth => ... argList */
{"resolveCmd", 1, 0, 0, {OPERAND_NONE}},
/* Resolves the command named on the top of the stack to its fully
* qualified version, or produces the empty string if no such command
* exists. Never generates errors.
* Stack: ... cmdName => ... fullCmdName */
{"tclooSelf", 1, +1, 0, {OPERAND_NONE}},
/* Push the identity of the current TclOO object (i.e., the name of
* its current public access command) on the stack. */
{"tclooClass", 1, 0, 0, {OPERAND_NONE}},
/* Push the class of the TclOO object named at the top of the stack
* onto the stack.
* Stack: ... object => ... class */
{"tclooNamespace", 1, 0, 0, {OPERAND_NONE}},
/* Push the namespace of the TclOO object named at the top of the
* stack onto the stack.
* Stack: ... object => ... namespace */
{"tclooIsObject", 1, 0, 0, {OPERAND_NONE}},
/* Push whether the value named at the top of the stack is a TclOO
* object (i.e., a boolean). Can corrupt the interpreter result
* despite not throwing, so not safe for use in a post-exception
* context.
* Stack: ... value => ... boolean */
{"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}},
/* Looks up the element on the top of the stack and tests whether it
* is an array. Pushes a boolean describing whether this is the
* case. Also runs the whole-array trace on the named variable, so can
* throw anything.
* Stack: ... varName => ... boolean */
{"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}},
/* Looks up the variable indexed by opnd and tests whether it is an
* array. Pushes a boolean describing whether this is the case. Also
* runs the whole-array trace on the named variable, so can throw
* anything.
* Stack: ... => ... boolean */
{"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}},
/* Forces the element on the top of the stack to be the name of an
* array.
* Stack: ... varName => ... */
{"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}},
/* Forces the variable indexed by opnd to be an array. Does not touch
* the stack. */
{"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}},
/* Invoke command named objv[0], replacing the first two words with
* the word at the top of the stack;
* <objc,objv> = <op4,top op4 after popping 1> */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
/*
* Prototypes for procedures defined later in this file:
*/
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 | /* * We copy the string before trying to find the command by * name. We used to modify the string in place, but this * is not safe because the name resolution handlers could * have side effects that rely on the unmodified string. */ | | | | | > > > | 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 |
/*
* We copy the string before trying to find the command by
* name. We used to modify the string in place, but this
* is not safe because the name resolution handlers could
* have side effects that rely on the unmodified string.
*/
TclDStringClear(&ds);
TclDStringAppendToken(&ds, &tokenPtr[1]);
cmdPtr = (Command *) Tcl_FindCommand(interp,
Tcl_DStringValue(&ds),
(Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
&& !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
int code, savedNumCmds = envPtr->numCommands;
unsigned savedCodeNext =
envPtr->codeNext - envPtr->codeStart;
int update = 0;
#ifdef TCL_COMPILE_DEBUG
int startStackDepth = envPtr->currStackDepth;
#endif
/*
* Mark the start of the command; the proper bytecode
* length will be updated later. There is no need to
* do this for the first bytecode in the compile env,
* as the check is done before calling
* TclNRExecuteByteCode(). Do emit an INST_START_CMD in
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 |
update = 1;
}
code = cmdPtr->compileProc(interp, parsePtr, cmdPtr,
envPtr);
if (code == TCL_OK) {
if (update) {
/*
* Fix the bytecode length.
*/
unsigned char *fixPtr = envPtr->codeStart
+ savedCodeNext + 1;
| > > > > > > > > > > > > > > > > > > > | 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 |
update = 1;
}
code = cmdPtr->compileProc(interp, parsePtr, cmdPtr,
envPtr);
if (code == TCL_OK) {
/*
* Confirm that the command compiler generated a
* single value on the stack as its result. This
* is only done in debugging mode, as it *should*
* be correct and normal users have no reasonable
* way to fix it anyway.
*/
#ifdef TCL_COMPILE_DEBUG
int diff = envPtr->currStackDepth-startStackDepth;
if (diff != 1 && (diff != 0 ||
*(envPtr->codeNext-1) != INST_DONE)) {
Tcl_Panic("bad stack adjustment when compiling"
" %.*s (was %d instead of 1)",
parsePtr->tokenPtr->size,
parsePtr->tokenPtr->start, diff);
}
#endif
if (update) {
/*
* Fix the bytecode length.
*/
unsigned char *fixPtr = envPtr->codeStart
+ savedCodeNext + 1;
|
| ︙ | ︙ | |||
2040 2041 2042 2043 2044 2045 2046 |
}
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
| | | 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 |
}
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
TclDStringAppendToken(&textBuffer, tokenPtr);
TclAdvanceLines(&envPtr->line, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
break;
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buffer);
|
| ︙ | ︙ | |||
2087 2088 2089 2090 2091 2092 2093 |
case TCL_TOKEN_COMMAND:
/*
* Push any accumulated chars appearing before the command.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
| | < < | 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 |
case TCL_TOKEN_COMMAND:
/*
* Push any accumulated chars appearing before the command.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
Tcl_DStringFree(&textBuffer);
if (numCL) {
TclContinuationsEnter(
|
| ︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 |
/*
* Push any accumulated chars appearing before the $<var>.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
| | < < | 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 |
/*
* Push any accumulated chars appearing before the $<var>.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
Tcl_DStringFree(&textBuffer);
}
TclCompileVarSubst(interp, tokenPtr, envPtr);
numObjsToConcat++;
|
| ︙ | ︙ | |||
2141 2142 2143 2144 2145 2146 2147 |
}
/*
* Push any accumulated characters appearing at the end.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
| | < < < | 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 |
}
/*
* Push any accumulated characters appearing at the end.
*/
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
if (numCL) {
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
numCL, clPosition);
}
numCL = 0;
}
|
| ︙ | ︙ | |||
4623 4624 4625 4626 4627 4628 4629 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 | < | 4737 4738 4739 4740 4741 4742 4743 4744 4745 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * End: */ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
672 673 674 675 676 677 678 | /* For [unset] compilation */ #define INST_UNSET_SCALAR 134 #define INST_UNSET_ARRAY 135 #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 | /* For [unset] compilation */ #define INST_UNSET_SCALAR 134 #define INST_UNSET_ARRAY 135 #define INST_UNSET_ARRAY_STK 136 #define INST_UNSET_STK 137 /* For [dict with], [dict exists], [dict create] and [dict merge] */ #define INST_DICT_EXPAND 138 #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 #define INST_DICT_EXISTS 141 #define INST_DICT_VERIFY 142 /* For [string map] and [regsub] compilation */ #define INST_STR_MAP 143 #define INST_STR_FIND 144 #define INST_STR_FIND_LAST 145 #define INST_STR_RANGE_IMM 146 #define INST_STR_RANGE 147 /* For operations to do with coroutines and other NRE-manipulators */ #define INST_YIELD 148 #define INST_COROUTINE_NAME 149 #define INST_TAILCALL 150 /* For compilation of basic information operations */ #define INST_NS_CURRENT 151 #define INST_INFO_LEVEL_NUM 152 #define INST_INFO_LEVEL_ARGS 153 #define INST_RESOLVE_COMMAND 154 #define INST_TCLOO_SELF 155 #define INST_TCLOO_CLASS 156 #define INST_TCLOO_NS 157 #define INST_TCLOO_IS_OBJECT 158 /* For compilation of [array] subcommands */ #define INST_ARRAY_EXISTS_STK 159 #define INST_ARRAY_EXISTS_IMM 160 #define INST_ARRAY_MAKE_STK 161 #define INST_ARRAY_MAKE_IMM 162 #define INST_INVOKE_REPLACE 163 /* The last opcode */ #define LAST_INST_OPCODE 163 /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed * and unsigned integers of length one and four bytes. The unsigned integers * are used for indexes or for, e.g., the count of objects to push in a "push" |
| ︙ | ︙ | |||
862 863 864 865 866 867 868 | /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ | < | | 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 | /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 |
/*
* Check if there is an LVT for compiled locals
*/
#define EnvHasLVT(envPtr) \
(envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr)
/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
/*
* Define the following macros to enable debug logging of the DTrace proc,
* cmd, and inst probes. Note that this does _not_ require a platform with
| > > > > > > > > > > | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 |
/*
* Check if there is an LVT for compiled locals
*/
#define EnvHasLVT(envPtr) \
(envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr)
/*
* Macros for making it easier to deal with tokens and DStrings.
*/
#define TclDStringAppendToken(dsPtr, tokenPtr) \
Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size)
#define TclRegisterDStringLiteral(envPtr, dsPtr) \
TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \
Tcl_DStringLength(dsPtr), /*flags*/ 0)
/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
/*
* Define the following macros to enable debug logging of the DTrace proc,
* cmd, and inst probes. Note that this does _not_ require a platform with
|
| ︙ | ︙ |
Changes to generic/tclConfig.c.
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
/*
* Now create the interface command for retrieval of the package
* information.
*/
Tcl_DStringInit(&cmdName);
| | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
/*
* Now create the interface command for retrieval of the package
* information.
*/
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "::");
Tcl_DStringAppend(&cmdName, pkgName, -1);
/*
* The incomplete command name is the name of the namespace to place it
* in.
*/
if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
TCL_GLOBAL_ONLY) == NULL) {
if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
NULL, NULL) == NULL) {
Tcl_Panic("%s.\n%s: %s",
Tcl_GetStringResult(interp), "Tcl_RegisterConfig",
"Unable to create namespace for package configuration.");
}
}
TclDStringAppendLiteral(&cmdName, "::pkgconfig");
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
"Unable to create query command for package configuration");
}
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 |
if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
|| pkgDict == NULL) {
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
| | | > | < | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
|| pkgDict == NULL) {
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
Tcl_GetString(pkgName), NULL);
return TCL_ERROR;
}
switch ((enum subcmds) index) {
case CFG_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return TCL_ERROR;
}
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
Tcl_GetString(objv[2]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, val);
return TCL_OK;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
if (n) {
Tcl_DictSearch s;
Tcl_Obj *key;
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
1803 1804 1805 1806 1807 1808 1809 1810 | void *procPtrs, Tcl_LoadHandle *handlePtr); /* 628 */ EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr); | > > > > | | | 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 |
void *procPtrs, Tcl_LoadHandle *handlePtr);
/* 628 */
EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle handle, const char *symbol);
/* 629 */
EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
Tcl_LoadHandle handlePtr);
/* 630 */
EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
typedef struct TclStubs {
int magic;
const TclStubHooks *hooks;
int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
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 */
char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
|
| ︙ | ︙ | |||
2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 |
Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */
int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */
int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */
int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */
int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
} TclStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
| > | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 |
Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */
int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */
int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */
int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */
int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */
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 */
} TclStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
|
| ︙ | ︙ | |||
3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 | (tclStubsPtr->tcl_NRSubstObj) /* 626 */ #define Tcl_LoadFile \ (tclStubsPtr->tcl_LoadFile) /* 627 */ #define Tcl_FindSymbol \ (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp | > > | 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 | (tclStubsPtr->tcl_NRSubstObj) /* 626 */ #define Tcl_LoadFile \ (tclStubsPtr->tcl_LoadFile) /* 627 */ #define Tcl_FindSymbol \ (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp |
| ︙ | ︙ | |||
3792 3793 3794 3795 3796 3797 3798 3799 |
EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLDECLS */
| > > > > > > > > > > > > | 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 |
EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
/*
* Deprecated Tcl procedures:
*/
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# undef Tcl_EvalObj
# 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)
#endif
#endif /* _TCLDECLS */
|
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 | static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); static int FinalizeDictUpdate(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeDictWith(ClientData data[], Tcl_Interp *interp, int result); static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictForLoopCallback(ClientData data[], Tcl_Interp *interp, int result); | > > | > | | | | | > | | | | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr);
static int FinalizeDictUpdate(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeDictWith(ClientData data[],
Tcl_Interp *interp, int result);
static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static int DictForLoopCallback(ClientData data[],
Tcl_Interp *interp, int result);
static int DictMapLoopCallback(ClientData data[],
Tcl_Interp *interp, int result);
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
{"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
{"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
{"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
{"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 },
{"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
{"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 },
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* Internal representation of the entries in the hash table that backs a
* dictionary.
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
TCL_HASH_KEY_TYPE_VERSION,
0,
TclHashObjKey,
TclCompareObjKeys,
AllocChainEntry,
TclFreeObjEntry
};
/***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/
/*
*----------------------------------------------------------------------
*
* AllocChainEntry --
| > > > > > > > > > > > > > > > > > | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
TCL_HASH_KEY_TYPE_VERSION,
0,
TclHashObjKey,
TclCompareObjKeys,
AllocChainEntry,
TclFreeObjEntry
};
/*
* Structure used in implementation of 'dict map' to hold the state that gets
* passed between parts of the implementation.
*/
typedef struct {
Tcl_Obj *keyVarObj; /* The name of the variable that will have
* keys assigned to it. */
Tcl_Obj *valueVarObj; /* The name of the variable that will have
* values assigned to it. */
Tcl_DictSearch search; /* The dictionary search structure. */
Tcl_Obj *scriptObj; /* The script to evaluate each time through
* the loop. */
Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the
* results. */
} DictMapStorage;
/***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/
/*
*----------------------------------------------------------------------
*
* AllocChainEntry --
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
dict->refcount = 1;
objPtr->internalRep.otherValuePtr = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
missingValue:
if (interp != NULL) {
| > | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 |
dict->refcount = 1;
objPtr->internalRep.otherValuePtr = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
missingValue:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
result = TCL_ERROR;
errorExit:
if (interp != NULL) {
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
|
| ︙ | ︙ | |||
775 776 777 778 779 780 781 |
int isNew; /* Dummy */
if (flags & DICT_PATH_EXISTS) {
return DICT_PATH_NON_EXISTENT;
}
if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
if (interp != NULL) {
| | < | > | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
int isNew; /* Dummy */
if (flags & DICT_PATH_EXISTS) {
return DICT_PATH_NON_EXISTENT;
}
if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(keyv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(keyv[i]), NULL);
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
{
Dict *dict;
Tcl_HashEntry *hPtr;
if (dictPtr->typePtr != &tclDictType) {
int result = SetDictFromAny(interp, dictPtr);
if (result != TCL_OK) {
return result;
}
}
dict = dictPtr->internalRep.otherValuePtr;
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
| > | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
{
Dict *dict;
Tcl_HashEntry *hPtr;
if (dictPtr->typePtr != &tclDictType) {
int result = SetDictFromAny(interp, dictPtr);
if (result != TCL_OK) {
*valuePtrPtr = NULL;
return result;
}
}
dict = dictPtr->internalRep.otherValuePtr;
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
|
| ︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 |
return TCL_ERROR;
}
result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
if (result != TCL_OK) {
return result;
}
if (valuePtr == NULL) {
| | < | > | 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 |
return TCL_ERROR;
}
result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
if (result != TCL_OK) {
return result;
}
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(objv[objc-1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(objv[objc-1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 |
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
Dict *dict;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
dictPtr = objv[1];
if (dictPtr->typePtr != &tclDictType) {
int result = SetDictFromAny(interp, dictPtr);
if (result != TCL_OK) {
return result;
}
}
dict = dictPtr->internalRep.otherValuePtr;
| > | > > | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 |
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
Dict *dict;
char *statsStr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
dictPtr = objv[1];
if (dictPtr->typePtr != &tclDictType) {
int result = SetDictFromAny(interp, dictPtr);
if (result != TCL_OK) {
return result;
}
}
dict = dictPtr->internalRep.otherValuePtr;
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
ckfree(statsStr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictIncrCmd --
|
| ︙ | ︙ | |||
2327 2328 2329 2330 2331 2332 2333 | } /* *---------------------------------------------------------------------- * * DictForNRCmd -- * | | | 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 | } /* *---------------------------------------------------------------------- * * DictForNRCmd -- * * These functions implement the "dict for" Tcl command. See the user * documentation for details on what it does, and TIP#111 for the formal * specification. * * Results: * A standard Tcl result. * * Side effects: |
| ︙ | ︙ | |||
2367 2368 2369 2370 2371 2372 2373 |
* Parse arguments.
*/
if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
| > | < | 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 |
* Parse arguments.
*/
if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
return TCL_ERROR;
}
searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2480 2481 2482 2483 2484 2485 2486 |
/*
* Stop the value from getting hit in any way by any traces on the key
* variable.
*/
Tcl_IncrRefCount(valueObj);
| | > | > | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 |
/*
* Stop the value from getting hit in any way by any traces on the key
* variable.
*/
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
result = TCL_ERROR;
goto done;
}
TclDecrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
result = TCL_ERROR;
goto done;
}
/*
* Run the script.
*/
|
| ︙ | ︙ | |||
2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 |
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
TclDecrRefCount(scriptObj);
Tcl_DictObjDone(searchPtr);
TclStackFree(interp, searchPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* DictSetCmd --
*
* This function implements the "dict set" Tcl command. See the user
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 |
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
TclDecrRefCount(scriptObj);
Tcl_DictObjDone(searchPtr);
TclStackFree(interp, searchPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* DictMapNRCmd --
*
* These functions implement the "dict map" Tcl command. See the user
* documentation for details on what it does, and TIP#405 for the formal
* specification.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMapNRCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
int varc, done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"{keyVar valueVar} dictionary script");
return TCL_ERROR;
}
/*
* Parse arguments.
*/
if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
return TCL_ERROR;
}
storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
&valueObj, &done) != TCL_OK) {
TclStackFree(interp, storagePtr);
return TCL_ERROR;
}
if (done) {
/*
* Note that this exit leaves an empty value in the result (due to
* command calling conventions) but that is OK since an empty value is
* an empty dictionary.
*/
TclStackFree(interp, storagePtr);
return TCL_OK;
}
TclNewObj(storagePtr->accumulatorObj);
TclListObjGetElements(NULL, objv[1], &varc, &varv);
storagePtr->keyVarObj = varv[0];
storagePtr->valueVarObj = varv[1];
storagePtr->scriptObj = objv[3];
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish. Note that the dictionary internal rep is locked
* internally so that updates, shimmering, etc are not a problem.
*/
Tcl_IncrRefCount(storagePtr->accumulatorObj);
Tcl_IncrRefCount(storagePtr->keyVarObj);
Tcl_IncrRefCount(storagePtr->valueVarObj);
Tcl_IncrRefCount(storagePtr->scriptObj);
/*
* Stop the value from getting hit in any way by any traces on the key
* variable.
*/
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
goto error;
}
if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
goto error;
}
TclDecrRefCount(valueObj);
/*
* Run the script.
*/
TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
iPtr->cmdFramePtr, 3);
/*
* For unwinding everything on error.
*/
error:
TclDecrRefCount(storagePtr->keyVarObj);
TclDecrRefCount(storagePtr->valueVarObj);
TclDecrRefCount(storagePtr->scriptObj);
TclDecrRefCount(storagePtr->accumulatorObj);
Tcl_DictObjDone(&storagePtr->search);
TclStackFree(interp, storagePtr);
return TCL_ERROR;
}
static int
DictMapLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
DictMapStorage *storagePtr = data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
/*
* Process the result from the previous execution of the script body.
*/
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 (\"dict map\" body line %d)",
Tcl_GetErrorLine(interp)));
}
goto done;
} else {
keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL,
TCL_LEAVE_ERR_MSG);
if (keyObj == NULL) {
result = TCL_ERROR;
goto done;
}
Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj,
Tcl_GetObjResult(interp));
}
/*
* Get the next mapping from the dictionary.
*/
Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done);
if (done) {
Tcl_SetObjResult(interp, storagePtr->accumulatorObj);
goto done;
}
/*
* Stop the value from getting hit in any way by any traces on the key
* variable.
*/
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
result = TCL_ERROR;
goto done;
}
if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
result = TCL_ERROR;
goto done;
}
TclDecrRefCount(valueObj);
/*
* Run the script.
*/
TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
iPtr->cmdFramePtr, 3);
/*
* For unwinding everything once the iterating is done.
*/
done:
TclDecrRefCount(storagePtr->keyVarObj);
TclDecrRefCount(storagePtr->valueVarObj);
TclDecrRefCount(storagePtr->scriptObj);
TclDecrRefCount(storagePtr->accumulatorObj);
Tcl_DictObjDone(&storagePtr->search);
TclStackFree(interp, storagePtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* DictSetCmd --
*
* This function implements the "dict set" Tcl command. See the user
|
| ︙ | ︙ | |||
2783 2784 2785 2786 2787 2788 2789 |
* copying from the "dict for" implementation has occurred!
*/
if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
| > | < | 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 |
* copying from the "dict for" implementation has occurred!
*/
if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
return TCL_ERROR;
}
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[4];
/*
|
| ︙ | ︙ | |||
2824 2825 2826 2827 2828 2829 2830 |
*/
Tcl_IncrRefCount(keyObj);
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
| > | | > | | > | 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 |
*/
Tcl_IncrRefCount(keyObj);
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set key variable: \"%s\"",
TclGetString(keyVarObj)));
result = TCL_ERROR;
goto abnormalResult;
}
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set value variable: \"%s\"",
TclGetString(valueVarObj)));
result = TCL_ERROR;
goto abnormalResult;
}
/*
* TIP #280. Make invoking context available to loop body.
*/
|
| ︙ | ︙ | |||
3434 3435 3436 3437 3438 3439 3440 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
| | | 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEncoding.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <sys/stat.h> #include "tclInt.h" typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. |
| ︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 |
map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
Tcl_DictObjPut(NULL, map, nameObj, dir[i]);
TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
}
}
if ((NULL == chan) && (interp != NULL)) {
| > | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
Tcl_DictObjPut(NULL, map, nameObj, dir[i]);
TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
}
}
if ((NULL == chan) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown encoding \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(nameObj);
Tcl_DecrRefCount(searchPath);
return chan;
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 |
encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan);
break;
case 'E':
encoding = LoadEscapeEncoding(name, chan);
break;
}
if ((encoding == NULL) && (interp != NULL)) {
| > | | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 |
encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan);
break;
case 'E':
encoding = LoadEscapeEncoding(name, chan);
break;
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid encoding file \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_Close(NULL, chan);
return encoding;
}
|
| ︙ | ︙ | |||
1868 1869 1870 1871 1872 1873 1874 |
goto doneParse;
}
/*
* Read lines from the encoding until EOF.
*/
| | | | 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 |
goto doneParse;
}
/*
* Read lines from the encoding until EOF.
*/
for (TclDStringClear(&lineString);
(len = Tcl_Gets(chan, &lineString)) >= 0;
TclDStringClear(&lineString)) {
const unsigned char *p;
int to, from;
/*
* Skip short lines.
*/
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
1 2 3 4 5 6 | /* * tclEnsemble.c -- * * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. * | | > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
/*
* tclEnsemble.c --
*
* Contains support for ensembles (see TIP#112), which provide simple
* mechanism for creating composite commands on top of namespaces.
*
* Copyright (c) 2005-2013 Donal K. Fellows.
*
* 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 "tclCompile.h"
/*
* Declarations for functions local to this file:
*/
static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
EnsembleConfig *ensemblePtr, int objc,
Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
static int 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);
static int NsEnsembleStringOrder(const void *strPtr1,
const void *strPtr2);
static void DeleteEnsembleConfig(ClientData clientData);
static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
const char *subcmdName, Tcl_Obj *prefixObjPtr);
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static int CompileToCompiledCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
CompileEnv *envPtr);
static void CompileToInvokedCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
Command *cmdPtr, CompileEnv *envPtr);
static int CompileBasicNArgCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr);
/*
* The lists of subcommands and options for the [namespace ensemble] command.
*/
static const char *const ensembleSubcommands[] = {
"configure", "create", "exists", NULL
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
const Tcl_ObjType tclEnsembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
StringOfEnsembleCmdRep, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* TclNamespaceEnsembleCmd --
*
* Invoked to implement the "namespace ensemble" command that creates and
| > > > > > > > > > > > > > > > > > > > > > > > > | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
const Tcl_ObjType tclEnsembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
StringOfEnsembleCmdRep, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* Copied from tclCompCmds.c
*/
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
int eclIndex = mapPtr->nuloc - 1
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
static inline Tcl_Obj *
NewNsObj(
Tcl_Namespace *namespacePtr)
{
register Namespace *nsPtr = (Namespace *) namespacePtr;
if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
return Tcl_NewStringObj("::", 2);
} else {
return Tcl_NewStringObj(nsPtr->fullName, -1);
}
}
/*
*----------------------------------------------------------------------
*
* TclNamespaceEnsembleCmd --
*
* Invoked to implement the "namespace ensemble" command that creates and
|
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
Tcl_Command token;
Tcl_DictSearch search;
Tcl_Obj *listObj;
int index, done;
if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
if (!Tcl_InterpDeleted(interp)) {
| | | > | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
Tcl_Command token;
Tcl_DictSearch search;
Tcl_Obj *listObj;
int index, done;
if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
-1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
}
return TCL_ERROR;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
if (len < 1) {
| | | > > | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
"must be non-empty lists", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
"EMPTY_TARGET", NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_NewListObj(len, listv);
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_NAMESPACE:
namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
| | < | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_NAMESPACE:
namespacePtr = NULL; /* silence gcc 4 warning */
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
break;
case CONF_PREFIX: {
int flags = 0; /* silence gcc 4 warning */
Tcl_GetEnsembleFlags(NULL, token, &flags);
Tcl_SetObjResult(interp,
Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 | /* -namespace option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE], -1)); namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); | | < < | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 | /* -namespace option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE], -1)); namespacePtr = NULL; /* silence gcc 4 warning */ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); /* -parameters option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1)); Tcl_GetEnsembleParameterList(NULL, token, &tmpObj); Tcl_ListObjAppendElement(NULL, resultObj, (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); |
| ︙ | ︙ | |||
511 512 513 514 515 516 517 |
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
if (len < 1) {
| | | > > | < | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
if (len < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble subcommand implementations "
"must be non-empty lists", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
"EMPTY_TARGET", NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
if (patchedDict == NULL) {
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
mapObj = (patchedDict ? patchedDict : objv[1]);
if (patchedDict) {
allocatedMapFlag = 1;
}
continue;
}
case CONF_NAMESPACE:
| > | > | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
mapObj = (patchedDict ? patchedDict : objv[1]);
if (patchedDict) {
allocatedMapFlag = 1;
}
continue;
}
case CONF_NAMESPACE:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"option -namespace is read-only", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
NULL);
goto freeMapAndError;
case CONF_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
goto freeMapAndError;
}
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
/*
* Make the name of the ensemble into a fully qualified name. This might
* allocate a temporary object.
*/
if (!(name[0] == ':' && name[1] == ':')) {
| | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
/*
* Make the name of the ensemble into a fully qualified name. This might
* allocate a temporary object.
*/
if (!(name[0] == ':' && name[1] == ':')) {
nameObj = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr == NULL) {
Tcl_AppendStringsToObj(nameObj, name, NULL);
} else {
Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
}
Tcl_IncrRefCount(nameObj);
name = TclGetString(nameObj);
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
Tcl_Obj *subcmdList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
| > | > | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
Tcl_Obj *subcmdList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (subcmdList != NULL) {
int length;
if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
int length;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
| > | > | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
int length;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (paramList == NULL) {
length = 0;
} else {
if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 |
Tcl_Obj *mapDict)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
| > | > | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
Tcl_Obj *mapDict)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
int size, done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
bytes = TclGetString(cmdObjPtr);
if (bytes[0] != ':' || bytes[1] != ':') {
| | > > | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
bytes = TclGetString(cmdObjPtr);
if (bytes[0] != ':' || bytes[1] != ':') {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble target is not a fully-qualified command",
-1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
"UNQUALIFIED_TARGET", NULL);
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
}
if (size < 1) {
mapDict = NULL;
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
Tcl_Obj *unknownList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
| > | > | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
Tcl_Obj *unknownList)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
if (unknownList != NULL) {
int length;
if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
int flags)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
int wasCompiled;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
| > | > | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 |
int flags)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
int wasCompiled;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
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;
wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
/*
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
Tcl_Obj **subcmdListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
| > | > | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 |
Tcl_Obj **subcmdListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
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;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 |
Tcl_Obj **paramListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
| > | > | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
Tcl_Obj **paramListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
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;
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
|
| ︙ | ︙ | |||
1160 1161 1162 1163 1164 1165 1166 |
Tcl_Obj **mapDictPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
| > | > | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 |
Tcl_Obj **mapDictPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
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;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
Tcl_Obj **unknownListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
| > | > | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 |
Tcl_Obj **unknownListPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
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;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
|
| ︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 |
int *flagsPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
| > | > | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 |
int *flagsPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
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;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
|
| ︙ | ︙ | |||
1277 1278 1279 1280 1281 1282 1283 |
Tcl_Namespace **namespacePtrPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
| > | > | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
Tcl_Namespace **namespacePtrPtr)
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
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;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 |
* rather than duplicating it.
*/
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
if (flags & TCL_LEAVE_ERR_MSG) {
| | | > | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
* rather than duplicating it.
*/
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not an ensemble command",
TclGetString(cmdNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
TclGetString(cmdNameObj), NULL);
}
return NULL;
}
}
|
| ︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 |
/*
* Construct the path for the ensemble namespace and create it.
*/
Tcl_DStringInit(&buf);
Tcl_DStringInit(&hiddenBuf);
| | | | | | 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 |
/*
* Construct the path for the ensemble namespace and create it.
*/
Tcl_DStringInit(&buf);
Tcl_DStringInit(&hiddenBuf);
TclDStringAppendLiteral(&hiddenBuf, "tcl:");
Tcl_DStringAppend(&hiddenBuf, name, -1);
TclDStringAppendLiteral(&hiddenBuf, ":");
hiddenLen = Tcl_DStringLength(&hiddenBuf);
if (name[0] == ':' && name[1] == ':') {
/*
* An absolute name, so use it directly.
*/
cmdName = name;
Tcl_DStringAppend(&buf, name, -1);
ensembleFlags = TCL_ENSEMBLE_PREFIX;
} else {
/*
* Not an absolute name, so do munging of it. Note that this treats a
* multi-word list differently to a single word.
*/
TclDStringAppendLiteral(&buf, "::tcl");
if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
Tcl_Panic("invalid ensemble name '%s'", name);
}
for (i = 0; i < nameCount; ++i) {
TclDStringAppendLiteral(&buf, "::");
Tcl_DStringAppend(&buf, nameParts[i], -1);
}
}
ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
TCL_CREATE_NS_IF_UNKNOWN);
if (!ns) {
|
| ︙ | ︙ | |||
1481 1482 1483 1484 1485 1486 1487 |
* Create the ensemble mapping dictionary and the ensemble command procs.
*/
if (ensemble != NULL) {
Tcl_Obj *mapDict, *fromObj, *toObj;
Command *cmdPtr;
| | | 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 |
* Create the ensemble mapping dictionary and the ensemble command procs.
*/
if (ensemble != NULL) {
Tcl_Obj *mapDict, *fromObj, *toObj;
Command *cmdPtr;
TclDStringAppendLiteral(&buf, "::");
TclNewObj(mapDict);
for (i=0 ; map[i].name != NULL ; i++) {
fromObj = Tcl_NewStringObj(map[i].name, -1);
TclNewStringObj(toObj, Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf));
Tcl_AppendToObj(toObj, map[i].name, -1);
Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 | cmdPtr = (Command *) Tcl_NRCreateCommand(interp, TclGetString(toObj), map[i].proc, map[i].nreProc, map[i].clientData, NULL); } cmdPtr->compileProc = map[i].compileProc; | < < < | > | > > | > > | | 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 |
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, TclGetString(toObj),
map[i].proc, map[i].nreProc, map[i].clientData,
NULL);
}
cmdPtr->compileProc = map[i].compileProc;
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
/*
* Switch on compilation always for core ensembles now that we can do
* nice bytecode things with them.
*/
Tcl_SetEnsembleFlags(interp, ensemble,
ensembleFlags | ENSEMBLE_COMPILE);
}
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
ckfree((char *) nameParts);
}
return ensemble;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 |
Tcl_Obj *prefixObj; /* An object containing the prefix words of
* the command that implements the
* subcommand. */
Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
* specified but not yet cached command
* names. */
int reparseCount = 0; /* Number of reparses. */
/*
* Must recheck objc, since numParameters might have changed. Cf. test
* namespace-53.9.
*/
restartEnsembleParse:
| > | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 |
Tcl_Obj *prefixObj; /* An object containing the prefix words of
* the command that implements the
* subcommand. */
Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
* specified but not yet cached command
* names. */
int reparseCount = 0; /* Number of reparses. */
Tcl_Obj *errorObj; /* Used for building error messages. */
/*
* Must recheck objc, since numParameters might have changed. Cf. test
* namespace-53.9.
*/
restartEnsembleParse:
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
if (ensemblePtr->parameterList == NULL) {
len = 0;
} else if (TclListObjGetElements(NULL, ensemblePtr->parameterList,
&len, &elemPtrs) != TCL_OK) {
Tcl_Panic("List of ensemble parameters is not a list");
}
for (; len>0; len--,elemPtrs++) {
| | | | | | > | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 |
if (ensemblePtr->parameterList == NULL) {
len = 0;
} else if (TclListObjGetElements(NULL, ensemblePtr->parameterList,
&len, &elemPtrs) != TCL_OK) {
Tcl_Panic("List of ensemble parameters is not a list");
}
for (; len>0; len--,elemPtrs++) {
TclDStringAppendObj(&buf, *elemPtrs);
TclDStringAppendLiteral(&buf, " ");
}
TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
return TCL_ERROR;
}
if (ensemblePtr->nsPtr->flags & NS_DYING) {
/*
* Don't know how we got here, but make things give up quickly.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble activated for deleted namespace", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
}
return TCL_ERROR;
}
/*
* Determine if the table of subcommands is right. If so, we can just look
* up in there and go straight to dispatch.
|
| ︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 | } } /* * Hand off to the target command. */ | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 |
}
}
/*
* Hand off to the target command.
*/
TclSkipTailcall(interp);
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
}
unknownOrAmbiguousSubcommand:
/*
* Have not been able to match the subcommand asked for with a real
* subcommand that we export. See whether a handler has been registered
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
* We cannot determine what subcommand to hand off to, so generate a
* (standard) failure message. Note the one odd case compared with
* standard ensemble-like command, which is where a namespace has no
* exported commands at all...
*/
Tcl_ResetResult(interp);
| | > | > | < | | | < | < | > | | | < | 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 |
* We cannot determine what subcommand to hand off to, so generate a
* (standard) failure message. Note the one odd case compared with
* standard ensemble-like command, which is where a namespace has no
* exported commands at all...
*/
Tcl_ResetResult(interp);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown subcommand \"%s\": namespace %s does not"
" export any commands",
TclGetString(objv[1+ensemblePtr->numParameters]),
ensemblePtr->nsPtr->fullName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
return TCL_ERROR;
}
errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
TclGetString(objv[1+ensemblePtr->numParameters]));
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
int i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
Tcl_AppendToObj(errorObj, ", ", 2);
}
Tcl_AppendPrintfToObj(errorObj, "or %s",
ensemblePtr->subcommandArrayPtr[i]);
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
int
TclClearRootEnsemble(
ClientData data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 |
EnsembleConfig *ensemblePtr,
int objc,
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
int paramc, i, result, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
| < | 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 |
EnsembleConfig *ensemblePtr,
int objc,
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
int paramc, i, result, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the unknown command callback to determine what to do.
*/
unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
TclNewObj(ensObj);
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 |
* Now call the unknown handler. (We don't bother NRE-enabling this; deep
* recursing through unknown handlers is horribly perverse.) Note that it
* is always an error for an unknown handler to delete its ensemble; don't
* do that!
*/
Tcl_Preserve(ensemblePtr);
| | > | | > | > | 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 |
* Now call the unknown handler. (We don't bother NRE-enabling this; deep
* recursing through unknown handlers is horribly perverse.) Note that it
* is always an error for an unknown handler to delete its ensemble; don't
* do that!
*/
Tcl_Preserve(ensemblePtr);
TclSkipTailcall(interp);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown subcommand handler deleted its ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
NULL);
}
result = TCL_ERROR;
}
Tcl_Release(ensemblePtr);
/*
* If we succeeded, we should either have a list of words that form the
* command to be executed, or an empty list. In the empty-list case, the
|
| ︙ | ︙ | |||
2108 2109 2110 2111 2112 2113 2114 |
/*
* Oh no! An exceptional result. Convert to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
| | | < | | | | < > > | 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 |
/*
* Oh no! An exceptional result. Convert to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown subcommand handler returned bad code: ", -1));
switch (result) {
case TCL_RETURN:
Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
break;
case TCL_BREAK:
Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
break;
case TCL_CONTINUE:
Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
break;
default:
Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
}
Tcl_AddErrorInfo(interp, "\n result of "
"ensemble unknown subcommand handler: ");
Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
NULL);
} else {
Tcl_AddErrorInfo(interp,
"\n (ensemble unknown subcommand handler)");
}
}
TclDecrRefCount(unknownCmd);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2388 2389 2390 2391 2392 2393 2394 | /* * Not there, 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). */ | | | 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 |
/*
* Not there, 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).
*/
cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
if (ensemblePtr->nsPtr->parentPtr != NULL) {
Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
} else {
Tcl_AppendStringsToObj(cmdObj, name, NULL);
}
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
|
| ︙ | ︙ | |||
2682 2683 2684 2685 2686 2687 2688 |
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| | > < > | > > | > | > > | > > > | < | | | | 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 |
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
unsigned numBytes;
const char *word;
Tcl_IncrRefCount(replaced);
/*
* This is where we return to if we are parsing multiple nested compiled
* ensembles. [info object] is such a beast.
*/
checkNextWord:
if (parsePtr->numWords < depth + 1) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Too hard.
*/
goto failed;
}
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
/*
* There's a sporting chance we'll be able to compile this. But now we
* must check properly. To do that, check that we're compiling an ensemble
* that has a compilable command as its appropriate subcommand.
*/
if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
|| mapObj == NULL) {
/*
* Either not an ensemble or a mapping isn't installed. Crud. Too hard
* to proceed.
*/
goto failed;
}
/*
* Also refuse to compile anything that uses a formal parameter list for
* now, on the grounds that it is too complex.
*/
if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
|| listObj != NULL) {
/*
* Figuring out how to compile this has become too much. Bail out.
*/
goto failed;
}
/*
* Next, get the flags. We need them on several code paths so that we can
* know whether we're to do prefix matching.
*/
|
| ︙ | ︙ | |||
2756 2757 2758 2759 2760 2761 2762 |
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
int sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
| | | > | | | > < > > | > > | > > > | > > > > > | < < > > | | | | > > > > | > > > > | > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > | | | | | | | | < < | | | > | > | > < | | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 |
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
int sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
goto failed;
}
for (i=0 ; i<len ; i++) {
str = Tcl_GetStringFromObj(elems[i], &sclen);
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
*/
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto failed;
}
replacement = elems[i];
goto doneMapLookup;
}
/*
* Check to see if we've got a prefix match. A single prefix match
* is fine, and allows us to refine our dictionary lookup, but
* multiple prefix matches is a Bad Thing and will prevent us from
* making progress. Note that we cannot do the lookup immediately
* in the prefix case; might be another entry later in the list
* that causes things to fail.
*/
if ((flags & TCL_ENSEMBLE_PREFIX)
&& strncmp(word, str, numBytes) == 0) {
if (matchObj != NULL) {
goto failed;
}
matchObj = elems[i];
}
}
if (matchObj == NULL) {
goto failed;
}
result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto failed;
}
replacement = matchObj;
} else {
Tcl_DictSearch s;
int done, matched;
Tcl_Obj *tmpObj;
/*
* No map, so check the dictionary directly.
*/
TclNewStringObj(subcmdObj, word, (int) numBytes);
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
if (result == TCL_OK && targetCmdObj != NULL) {
/*
* Got it. Skip the fiddling around with prefixes.
*/
replacement = subcmdObj;
goto doneMapLookup;
}
TclDecrRefCount(subcmdObj);
/*
* We've not literally got a valid subcommand. But maybe we have a
* prefix. Check if prefix matches are allowed.
*/
if (!(flags & TCL_ENSEMBLE_PREFIX)) {
goto failed;
}
/*
* Iterate over the keys in the dictionary, checking to see if we're a
* prefix.
*/
Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
matched = 0;
replacement = NULL; /* Silence, fool compiler! */
while (!done) {
if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
if (matched++) {
/*
* Must have matched twice! Not unique, so no point
* looking further.
*/
break;
}
replacement = subcmdObj;
targetCmdObj = tmpObj;
}
Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
}
Tcl_DictObjDone(&s);
/*
* If we have anything other than a single match, we've failed the
* unique prefix check.
*/
if (matched != 1) {
invokeAnyway = 1;
goto failed;
}
}
/*
* OK, we definitely map to something. But what?
*
* The command we map to is the first word out of the map element. Note
* that we also reject dealing with multi-element rewrites if we are in a
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
* Tcl crash open to exploit.
*/
doneMapLookup:
Tcl_ListObjAppendElement(NULL, replaced, replacement);
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto failed;
} else if (len != 1) {
/*
* Note that at this point we know we can't issue any special
* instruction sequence as the mapping isn't one that we support at
* the compiled level.
*/
goto cleanup;
}
targetCmdObj = elems[0];
oldCmdPtr = cmdPtr;
Tcl_IncrRefCount(targetCmdObj);
newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
TclDecrRefCount(targetCmdObj);
if (newCmdPtr == NULL || Tcl_IsSafe(interp)
|| newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
|| newCmdPtr->flags & CMD_HAS_EXEC_TRACES
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
/*
* Maps to an undefined command or a command without a compiler.
* Cannot compile.
*/
goto cleanup;
}
cmdPtr = newCmdPtr;
depth++;
/*
* See whether we have a nested ensemble. If we do, we can go round the
* mulberry bush again, consuming the next word.
*/
if (cmdPtr->compileProc == TclCompileEnsemble) {
tokenPtr = TokenAfter(tokenPtr);
ensemble = (Tcl_Command) cmdPtr;
goto checkNextWord;
}
/*
* Now we've done the mapping process, can now actually try to compile.
* If there is a subcommand compiler and that successfully produces code,
* we'll use that. Otherwise, we fall back to generating opcodes to do the
* invoke at runtime.
*/
invokeAnyway = 1;
if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr,
envPtr) == TCL_OK) {
ourResult = TCL_OK;
goto cleanup;
}
/*
* Failed to do a full compile for some reason. Try to do a direct invoke
* instead of going through the ensemble lookup process again.
*/
failed:
if (depth < 250) {
if (depth > 1) {
if (!invokeAnyway) {
cmdPtr = oldCmdPtr;
depth--;
}
(void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL);
}
CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
ourResult = TCL_OK;
}
/*
* Release the memory we allocated. If we've got here, we've either done
* something useful or we're in a case that we can't compile at all and
* we're just giving up.
*/
cleanup:
Tcl_DecrRefCount(replaced);
return ourResult;
}
/*
* How to compile a subcommand using its own command compiler. To do that, we
* have to perform some trickery to rewrite the arguments, as compilers *must*
* have parse tokens that refer to addresses in the original script.
*/
static int
CompileToCompiledCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Parse synthetic;
Tcl_Token *tokenPtr;
int result, i;
int savedNumCmds = envPtr->numCommands;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
TclParseInit(interp, NULL, 0, &synthetic);
synthetic.numWords = parsePtr->numWords - depth + 1;
TclGrowParseTokenArray(&synthetic, 2);
synthetic.numTokens = 2;
/*
* Now we have the space to work in, install something rewritten. The
* first word will "officially" be the bytes of the structured ensemble
* name. That's technically wrong, but nobody will care; we just need
* *something* here...
*/
synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD;
synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start;
synthetic.tokenPtr[0].numComponents = 1;
synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT;
synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start;
synthetic.tokenPtr[1].numComponents = 0;
for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) {
int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start)
+ tokenPtr->size;
synthetic.tokenPtr[0].size = sclen;
synthetic.tokenPtr[1].size = sclen;
tokenPtr = TokenAfter(tokenPtr);
}
/*
* Copy over the real argument tokens.
*/
for (i=1; i<synthetic.numWords; i++) {
int toCopy;
toCopy = tokenPtr->numComponents + 1;
TclGrowParseTokenArray(&synthetic, toCopy);
memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
sizeof(Tcl_Token) * toCopy);
synthetic.numTokens += toCopy;
tokenPtr = TokenAfter(tokenPtr);
}
/*
* Hand off compilation to the subcommand compiler. At last!
*/
result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
/*
* If our target fails to compile, revert the number of commands and the
* pointer to the place to issue the next instruction. [Bug 3600328]
*/
if (result != TCL_OK) {
envPtr->numCommands = savedNumCmds;
envPtr->currStackDepth = savedStackDepth;
envPtr->codeNext = envPtr->codeStart + savedCodeNext;
}
/*
* Clean up if necessary.
*/
Tcl_FreeParse(&synthetic);
return result;
}
/*
* How to compile a subcommand to a _replacing_ invoke of its implementation
* command.
*/
static void
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
int length, i, numWords, cmdLit;
DefineLineInformation;
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
* difference. Hence the call to TclContinuationsEnterDerived...
*/
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
if (i > 0 && i < numWords+1) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
} else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterNewLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size);
if (envPtr->clNext) {
TclContinuationsEnterDerived(
envPtr->literalArrayPtr[literal].objPtr,
tokPtr[1].start - envPtr->source,
mapPtr->loc[eclIndex].next[i]);
}
TclEmitPush(literal, envPtr);
} else {
if (envPtr->clNext) {
SetLineInformation(i);
}
CompileTokens(envPtr, tokPtr, interp);
}
tokPtr = TokenAfter(tokPtr);
}
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
/*
* Do the replacing dispatch.
*/
TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
TclEmitInt1(numWords+1, envPtr);
TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */
}
/*
* Helpers that do issuing of instructions for commands that "don't have
* compilers" (well, they do; these). They all work by just generating base
* code to invoke the command; they're intended for ensemble subcommands so
* that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
* that they're not needed.
*
* Note that these are NOT suitable for commands where there's an argument
* that is a script, as an [info level] or [info frame] in the inner context
* can see the difference.
*/
static int
CompileBasicNArgCommand(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
char *bytes;
int length, i, literal;
DefineLineInformation;
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr);
TclEmitPush(literal, envPtr);
TclDecrRefCount(objPtr);
/*
* Push the words of the command.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=1 ; i<parsePtr->numWords ; i++) {
if (envPtr->clNext) {
SetLineInformation(i);
}
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size);
} else {
CompileTokens(envPtr, tokenPtr, interp);
}
tokenPtr = TokenAfter(tokenPtr);
}
/*
* Do the standard dispatch.
*/
if (i <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr);
} else {
TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr);
}
return TCL_OK;
}
int
TclCompileBasic0ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 1) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic1ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic2ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic3ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic0Or1ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic1Or2ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic2Or3ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic0To2ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasic1To3ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasicMin0ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords < 1) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasicMin1ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords < 2) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileBasicMin2ArgCmd(
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. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Verify that the number of arguments is correct; that's the only case
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
* which is the only code that sees the shenanigans of ensemble dispatch.
*/
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
unsetenv("Path");
if (value == NULL) {
buf = NULL;
} else {
int size;
| | | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
unsetenv("Path");
if (value == NULL) {
buf = NULL;
} else {
int size;
size = cygwin_conv_path_list(0, value, NULL, 0);
buf = alloca(size + 1);
cygwin_conv_path_list(0, value, buf, size);
}
SetEnvironmentVariableA(name, buf);
}
}
#endif /* __CYGWIN__ */
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 |
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
| | | | > | 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
break;
}
}
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done);
if (!foundEvent) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't wait for variable \"%s\": would wait forever",
nameString));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
if (!done) {
/*
* The interpreter's result was already set to the right error message
* prior to exiting the loop above.
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
while (Tcl_DoOneEvent(flags) != 0) {
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
return TCL_ERROR;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
| | | 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 |
while (Tcl_DoOneEvent(flags) != 0) {
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
return TCL_ERROR;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
}
/*
* Must clear the interpreter's result because event handlers could have
* executed commands.
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * * 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 "tclCompile.h" #include "tommath.h" #include <math.h> #if NRE_ENABLE_ASSERTS #include <assert.h> #endif | > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * * 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 "tclCompile.h" #include "tclOOInt.h" #include "tommath.h" #include <math.h> #if NRE_ENABLE_ASSERTS #include <assert.h> #endif |
| ︙ | ︙ | |||
246 247 248 249 250 251 252 | * ARGUMENTS: * pcAdjustment: how much to increment pc * nCleanup: how many objects to remove from the stack * resultHandling: 0 indicates no object should be pushed on the stack; * otherwise, push objResultPtr. If (result < 0), objResultPtr already * has the correct reference count. * | | > > > > > > > > > > > > > | > | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
* ARGUMENTS:
* pcAdjustment: how much to increment pc
* nCleanup: how many objects to remove from the stack
* resultHandling: 0 indicates no object should be pushed on the stack;
* otherwise, push objResultPtr. If (result < 0), objResultPtr already
* has the correct reference count.
*
* We use the new compile-time assertions to check that nCleanup is constant
* and within range.
*/
/* Verify the stack depth, only when no expansion is in progress */
#if TCL_COMPILE_DEBUG
#define CHECK_STACK() \
do { \
ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
/*checkStack*/ !(starting || auxObjList)); \
starting = 0; \
} while (0)
#else
#define CHECK_STACK()
#endif
#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
do { \
TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
CHECK_STACK(); \
if (nCleanup == 0) { \
if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
PUSH_OBJECT(objResultPtr); \
} else { \
*(++tosPtr) = objResultPtr; \
} \
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
switch (nCleanup) { \
case 1: goto cleanup1; \
case 2: goto cleanup2; \
} \
} \
} while (0)
| | > | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 |
switch (nCleanup) { \
case 1: goto cleanup1; \
case 2: goto cleanup2; \
} \
} \
} while (0)
#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
CHECK_STACK(); \
do { \
pc += (pcAdjustment); \
cleanup = (nCleanup); \
if (resultHandling) { \
if ((resultHandling) > 0) { \
Tcl_IncrRefCount(objResultPtr); \
} \
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 | #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, const unsigned char *pc, int stackTop, | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 | #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, const unsigned char *pc, int stackTop, int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); |
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
if (!markerPtr) {
Tcl_Panic("STACK: Reallocating with no previous alloc");
}
if (needed <= 0) {
return MEMSTART(markerPtr);
}
} else {
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
int offset = OFFSET(tmpMarkerPtr);
if (needed + offset < 0) {
/*
* Put a marker pointing to the previous marker in this stack, and
* store it in esPtr as the current marker. Return a pointer to
* the start of aligned memory.
*/
esPtr->markerPtr = tmpMarkerPtr;
memStart = tmpMarkerPtr + offset;
esPtr->tosPtr = memStart - 1;
*esPtr->markerPtr = (Tcl_Obj *) markerPtr;
return memStart;
}
}
/*
* Reset move to hold the number of words to be moved to new stack (if
* any) and growth to hold the complete stack requirements: add one for
* the marker, (WALLOCALIGN-1) for the maximal possible offset.
*/
if (move) {
moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
}
needed = growth + moveWords + WALLOCALIGN;
/*
* Check if there is enough room in the next stack (if there is one, it
* should be both empty and the last one!)
*/
if (esPtr->nextPtr) {
oldPtr = esPtr;
| > > > | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
if (!markerPtr) {
Tcl_Panic("STACK: Reallocating with no previous alloc");
}
if (needed <= 0) {
return MEMSTART(markerPtr);
}
} else {
#ifndef PURIFY
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
int offset = OFFSET(tmpMarkerPtr);
if (needed + offset < 0) {
/*
* Put a marker pointing to the previous marker in this stack, and
* store it in esPtr as the current marker. Return a pointer to
* the start of aligned memory.
*/
esPtr->markerPtr = tmpMarkerPtr;
memStart = tmpMarkerPtr + offset;
esPtr->tosPtr = memStart - 1;
*esPtr->markerPtr = (Tcl_Obj *) markerPtr;
return memStart;
}
#endif
}
/*
* Reset move to hold the number of words to be moved to new stack (if
* any) and growth to hold the complete stack requirements: add one for
* the marker, (WALLOCALIGN-1) for the maximal possible offset.
*/
if (move) {
moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
}
needed = growth + moveWords + WALLOCALIGN;
/*
* Check if there is enough room in the next stack (if there is one, it
* should be both empty and the last one!)
*/
if (esPtr->nextPtr) {
oldPtr = esPtr;
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 |
}
/*
* We need to allocate a new stack! It needs to store 'growth' words,
* including the elements to be copied over and the new marker.
*/
newElems = 2*currElems;
while (needed > newElems) {
newElems *= 2;
}
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
| > > > > > | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 |
}
/*
* We need to allocate a new stack! It needs to store 'growth' words,
* including the elements to be copied over and the new marker.
*/
#ifndef PURIFY
newElems = 2*currElems;
while (needed > newElems) {
newElems *= 2;
}
#else
newElems = needed;
#endif
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
|
| ︙ | ︙ | |||
1207 1208 1209 1210 1211 1212 1213 |
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
| | | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
ckfree((char *) freePtr);
return;
}
/*
* Rewind the stack to the previous marker position. The current marker,
* as set in the last call to GrowEvaluationStack, contains a pointer to
* the previous marker.
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
DeleteExecStack(tmpPtr);
} else {
break;
}
}
if (esPtr->prevPtr) {
eePtr->execStackPtr = esPtr->prevPtr;
} else {
eePtr->execStackPtr = esPtr;
}
}
void *
TclStackAlloc(
Tcl_Interp *interp,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
| > > > > | | | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 |
DeleteExecStack(tmpPtr);
} else {
break;
}
}
if (esPtr->prevPtr) {
eePtr->execStackPtr = esPtr->prevPtr;
#ifdef PURIFY
eePtr->execStackPtr->nextPtr = NULL;
DeleteExecStack(esPtr);
#endif
} else {
eePtr->execStackPtr = esPtr;
}
}
void *
TclStackAlloc(
Tcl_Interp *interp,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckalloc(numBytes);
}
return (void *) StackAllocWords(interp, numWords);
}
void *
TclStackRealloc(
Tcl_Interp *interp,
void *ptr,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;
int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckrealloc((char *) ptr, numBytes);
}
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;
if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {
|
| ︙ | ︙ | |||
2055 2056 2057 2058 2059 2060 2061 |
/*
* Globals: variables that store state, must remain valid at all times.
*/
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc; /* The current program counter. */
| > | | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
/*
* Globals: variables that store state, must remain valid at all times.
*/
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc; /* The current program counter. */
unsigned char inst; /* The currently running instruction */
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
int cleanup = 0;
Tcl_Obj *objResultPtr;
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 |
int opnd, length, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
#endif
#ifdef TCL_COMPILE_DEBUG
traceInstructions = (tclTraceExec == 3);
#endif
TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
if (!data[1] && (tclTraceExec >= 2)) {
| > | 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 |
int opnd, length, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
#endif
#ifdef TCL_COMPILE_DEBUG
int starting = 1;
traceInstructions = (tclTraceExec == 3);
#endif
TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
if (!data[1] && (tclTraceExec >= 2)) {
|
| ︙ | ︙ | |||
2221 2222 2223 2224 2225 2226 2227 |
* compilers (SunPro CC).
*/
break;
}
cleanup0:
| < < < < < < < < < < < < < < < < < < | 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 |
* compilers (SunPro CC).
*/
break;
}
cleanup0:
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
*/
if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
2270 2271 2272 2273 2274 2275 2276 |
CACHE_STACK_INFO();
goto gotError;
}
}
CACHE_STACK_INFO();
}
| < < > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > | | | > > > > | | 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 |
CACHE_STACK_INFO();
goto gotError;
}
}
CACHE_STACK_INFO();
}
/*
* These two instructions account for 26% of all instructions (according
* to measurements on tclbench by Ben Vitale
* [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf]
* Resolving them before the switch reduces the cost of branch
* mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!)
* reduces total obj size.
*/
inst = *pc;
peepholeStart:
#ifdef TCL_COMPILE_STATS
iPtr->stats.instructionCount[*pc]++;
#endif
#ifdef TCL_COMPILE_DEBUG
/*
* Skip the stack depth check if an expansion is in progress.
*/
CHECK_STACK();
if (traceInstructions) {
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
#endif /* TCL_COMPILE_DEBUG */
TCL_DTRACE_INST_NEXT();
if (inst == INST_LOAD_SCALAR1) {
goto instLoadScalar1;
} else if (inst == INST_PUSH1) {
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
inst = *(pc += 2);
goto peepholeStart;
} else if (inst == INST_START_CMD) {
/*
* Peephole: do not run INST_START_CMD, just skip it
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (checkInterp) {
checkInterp = 0;
if ((codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) {
goto instStartCmdFailed;
}
}
inst = *(pc += 9);
goto peepholeStart;
}
switch (inst) {
case INST_SYNTAX:
case INST_RETURN_IMM: {
int code = TclGetInt4AtPtr(pc+1);
int level = TclGetUInt4AtPtr(pc+5);
/*
* OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr.
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 |
TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
}
Tcl_SetObjResult(interp, objResultPtr);
cleanup = 1;
goto processExceptionReturn;
case INST_DONE:
if (tosPtr > initTosPtr) {
/*
* Set the interpreter's object result to point to the topmost
* object from the stack, and check for a possible [catch]. The
* stackTop's level and refCount will be handled by "processCatch"
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 |
TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
}
Tcl_SetObjResult(interp, objResultPtr);
cleanup = 1;
goto processExceptionReturn;
case INST_YIELD: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
if (!corPtr) {
TRACE_APPEND(("ERROR: yield outside coroutine\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yield can only be called in a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
NULL);
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
if (traceInstructions) {
fprintf(stdout, "\n");
}
#endif
/* TIP #280: Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
*/
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);
}
pc++;
cleanup = 1;
TEBC_YIELD();
Tcl_SetObjResult(interp, OBJ_AT_TOS);
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
INT2PTR(0), NULL, NULL);
return TCL_OK;
}
case INST_TAILCALL: {
Tcl_Obj *listPtr, *nsObjPtr;
opnd = TclGetUInt1AtPtr(pc+1);
if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc or lambda", -1));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
{
register int i;
TRACE(("%d [", opnd));
for (i=opnd-1 ; i>=0 ; i--) {
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
if (i > 0) {
TRACE_APPEND((" "));
}
}
TRACE_APPEND(("] => RETURN..."));
}
#endif
/*
* Push the evaluation of the called command into the NR callback
* stack.
*/
listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
if (iPtr->varFramePtr->tailcallPtr) {
Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
}
iPtr->varFramePtr->tailcallPtr = listPtr;
result = TCL_RETURN;
cleanup = opnd;
goto processExceptionReturn;
}
case INST_DONE:
if (tosPtr > initTosPtr) {
/*
* Set the interpreter's object result to point to the topmost
* object from the stack, and check for a possible [catch]. The
* stackTop's level and refCount will be handled by "processCatch"
|
| ︙ | ︙ | |||
2349 2350 2351 2352 2353 2354 2355 | } #endif goto checkForCatch; } (void) POP_OBJECT(); goto abnormalReturn; | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < | 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 |
}
#endif
goto checkForCatch;
}
(void) POP_OBJECT();
goto abnormalReturn;
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
NEXT_INST_F(1, 0, 0);
case INST_NOP:
NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_OVER:
|
| ︙ | ︙ | |||
2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 |
case INST_CALL_BUILTIN_FUNC1:
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
case INST_CALL_FUNC1:
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
/*
* -----------------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
* instructions set the value of some variables and then jump to some
* common execution code.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 |
case INST_CALL_BUILTIN_FUNC1:
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
case INST_CALL_FUNC1:
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
case INST_INVOKE_REPLACE:
objc = TclGetUInt4AtPtr(pc+1);
opnd = TclGetUInt1AtPtr(pc+5);
objPtr = POP_OBJECT();
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
int i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr)));
} else {
fprintf(stdout,
"%d: (%u) invoking (using implementation %s) ",
iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
O2S(objPtr));
}
for (i = 0; i < objc; i++) {
if (i < opnd) {
fprintf(stdout, "<");
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, ">");
} else {
TclPrintObject(stdout, objv[i], 15);
}
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
{
Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
Tcl_Obj **copyObjv = &listRepPtr->elements;
int i;
listRepPtr->elemCount = objc - opnd + 1;
copyObjv[0] = objPtr;
memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd));
for (i=1 ; i<objc-opnd+1 ; i++) {
Tcl_IncrRefCount(copyObjv[i]);
}
objPtr = copyPtr;
}
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);
}
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = opnd;
iPtr->ensembleRewrite.numInsertedObjs = 1;
DECACHE_STACK_INFO();
pc += 6;
TEBC_YIELD();
TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
TclSkipTailcall(interp);
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
/*
* -----------------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
* instructions set the value of some variables and then jump to some
* common execution code.
|
| ︙ | ︙ | |||
3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 |
CACHE_STACK_INFO();
}
NEXT_INST_F(5, 0, 0);
}
/*
* End of INST_UNSET instructions.
* -----------------------------------------------------------------
* Start of variable linking instructions.
*/
{
Var *otherPtr;
CallFrame *framePtr, *savedFramePtr;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 |
CACHE_STACK_INFO();
}
NEXT_INST_F(5, 0, 0);
}
/*
* End of INST_UNSET instructions.
* -----------------------------------------------------------------
* Start of INST_ARRAY instructions.
*/
case INST_ARRAY_EXISTS_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
cleanup = 0;
part1Ptr = NULL;
arrayPtr = NULL;
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
goto doArrayExists;
case INST_ARRAY_EXISTS_STK:
opnd = -1;
pcAdjustment = 1;
cleanup = 1;
part1Ptr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
/*createPart1*/0, /*createPart2*/0, &arrayPtr);
doArrayExists:
if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
DECACHE_STACK_INFO();
result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,
NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|
TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
CACHE_STACK_INFO();
if (result == TCL_ERROR) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
}
if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
objResultPtr = TCONST(1);
} else {
objResultPtr = TCONST(0);
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
case INST_ARRAY_MAKE_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
cleanup = 0;
part1Ptr = NULL;
arrayPtr = NULL;
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
goto doArrayMake;
case INST_ARRAY_MAKE_STK:
opnd = -1;
pcAdjustment = 1;
cleanup = 1;
part1Ptr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/1, /*createPart2*/0, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
doArrayMake:
if (varPtr && !TclIsVarArray(varPtr)) {
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
* Either an array element, or a scalar: lose!
*/
TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
"variable isn't array", opnd);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
TRACE_APPEND(("ERROR: bad array ref: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TclSetVarArray(varPtr);
varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
TclInitVarHashTable(varPtr->value.tablePtr,
TclGetVarNsPtr(varPtr));
#ifdef TCL_COMPILE_DEBUG
TRACE_APPEND(("done\n"));
} else {
TRACE_APPEND(("nothing to do\n"));
#endif
}
NEXT_INST_V(pcAdjustment, cleanup, 0);
/*
* End of INST_ARRAY instructions.
* -----------------------------------------------------------------
* Start of variable linking instructions.
*/
{
Var *otherPtr;
CallFrame *framePtr, *savedFramePtr;
|
| ︙ | ︙ | |||
4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 |
} else {
iResult = (i1 && i2);
}
objResultPtr = TCONST(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
NEXT_INST_F(1, 2, 1);
}
/*
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 |
} else {
iResult = (i1 && i2);
}
objResultPtr = TCONST(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
NEXT_INST_F(1, 2, 1);
}
/*
* -----------------------------------------------------------------
* Start of general introspector instructions.
*/
case INST_NS_CURRENT: {
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
TclNewLiteralStringObj(objResultPtr, "::");
} else {
TclNewStringObj(objResultPtr, currNsPtr->fullName,
strlen(currNsPtr->fullName));
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
int level;
register CallFrame *framePtr = iPtr->varFramePtr;
register CallFrame *rootFramePtr = iPtr->rootFramePtr;
valuePtr = OBJ_AT_TOS;
if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
goto gotError;
}
TRACE(("%d => ", level));
if (level <= 0) {
level += framePtr->level;
}
for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ;
framePtr = framePtr->callerVarPtr) {
/* Empty loop body */
}
if (framePtr == rootFramePtr) {
Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr),
"\"", NULL);
TRACE_APPEND(("ERROR: bad level\n"));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
TclGetString(valuePtr), NULL);
goto gotError;
}
objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
case INST_RESOLVE_COMMAND: {
Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
TclNewObj(objResultPtr);
if (cmd != NULL) {
Tcl_GetCommandFullName(interp, cmd, objResultPtr);
}
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
}
case INST_TCLOO_SELF: {
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE(("=> ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"self may only be called from inside a method",
-1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
goto gotError;
}
contextPtr = framePtr->clientData;
/*
* Call out to get the name; it's expensive to compute but cached.
*/
objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
{
Object *oPtr;
case INST_TCLOO_IS_OBJECT:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
objResultPtr = TCONST(oPtr != NULL ? 1 : 0);
TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
case INST_TCLOO_CLASS:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
if (oPtr == NULL) {
TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
goto gotError;
}
objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr);
TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
case INST_TCLOO_NS:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
if (oPtr == NULL) {
TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
goto gotError;
}
/*
* TclOO objects *never* have the global namespace as their NS.
*/
TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName,
strlen(oPtr->namespacePtr->fullName));
TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
}
/*
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
|
| ︙ | ︙ | |||
4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 |
length = Tcl_UniCharToUtf(ch, buf);
objResultPtr = Tcl_NewStringObj(buf, length);
}
TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_MATCH:
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
/*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 |
length = Tcl_UniCharToUtf(ch, buf);
objResultPtr = Tcl_NewStringObj(buf, length);
}
TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_RANGE:
TRACE(("\"%.20s\" %s %s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
&toIdx) != TCL_OK) {
goto gotError;
}
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= length) {
toIdx = length;
}
if (toIdx >= fromIdx) {
objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
} else {
TclNewObj(objResultPtr);
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(1, 3, 1);
case INST_STR_RANGE_IMM:
valuePtr = OBJ_AT_TOS;
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
length = Tcl_GetCharLength(valuePtr);
TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
/*
* Adjust indices for end-based indexing.
*/
if (fromIdx < -1) {
fromIdx += 1 + length;
if (fromIdx < 0) {
fromIdx = 0;
}
} else if (fromIdx >= length) {
fromIdx = length;
}
if (toIdx < -1) {
toIdx += 1 + length;
} else if (toIdx >= length) {
toIdx = length - 1;
}
/*
* Check if we can do a sane substring.
*/
if (fromIdx <= toIdx) {
objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
} else {
TclNewObj(objResultPtr);
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
{
Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
int length3;
Tcl_Obj *value3Ptr;
case INST_STR_MAP:
valuePtr = OBJ_AT_TOS; /* "Main" string. */
value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */
value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */
if (value3Ptr == value2Ptr) {
objResultPtr = valuePtr;
NEXT_INST_V(1, 3, 1);
} else if (valuePtr == value2Ptr) {
objResultPtr = value3Ptr;
NEXT_INST_V(1, 3, 1);
}
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
if (length == 0) {
objResultPtr = valuePtr;
NEXT_INST_V(1, 3, 1);
}
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
if (length2 > length || length2 == 0) {
objResultPtr = valuePtr;
NEXT_INST_V(1, 3, 1);
} else if (length2 == length) {
if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
objResultPtr = valuePtr;
} else {
objResultPtr = value3Ptr;
}
NEXT_INST_V(1, 3, 1);
}
ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
p = ustring1;
end = ustring1 + length;
for (; ustring1 < end; ustring1++) {
if ((*ustring1 == *ustring2) && (length2==1 ||
memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
== 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
}
}
if (p != ustring1) {
/*
* Put the rest of the unmapped chars onto result.
*/
Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
}
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
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;
}
}
}
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
TclNewIntObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
match = -1;
if (length2 > 0 && length2 <= length) {
for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
if ((*p == *ustring2) &&
memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
match = p - ustring1;
break;
}
}
}
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
TclNewIntObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
}
case INST_STR_MATCH:
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
/*
|
| ︙ | ︙ | |||
4892 4893 4894 4895 4896 4897 4898 |
}
lResult = l1 - l2*lResult;
goto longResultOfArithmetic;
}
case INST_RSHIFT:
if (l2 < 0) {
| > | < | 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 |
}
lResult = l1 - l2*lResult;
goto longResultOfArithmetic;
}
case INST_RSHIFT:
if (l2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
NULL);
CACHE_STACK_INFO();
#endif
|
| ︙ | ︙ | |||
4940 4941 4942 4943 4944 4945 4946 |
lResult = l1 >> ((int) l2);
goto longResultOfArithmetic;
}
case INST_LSHIFT:
if (l2 < 0) {
| > | < | 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 |
lResult = l1 >> ((int) l2);
goto longResultOfArithmetic;
}
case INST_LSHIFT:
if (l2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#if 0
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
NULL);
CACHE_STACK_INFO();
#endif
|
| ︙ | ︙ | |||
4963 4964 4965 4966 4967 4968 4969 | /* * 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 work, and it takes only an int argument, that's a * good place to draw the line. */ | | | < | 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 | /* * 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 work, and it takes only an int argument, that's a * good place to draw the line. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); #if 0 DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); CACHE_STACK_INFO(); #endif goto gotError; |
| ︙ | ︙ | |||
5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 |
{
int opnd2, allocateDict, done, i, allocdict;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
DictUpdateInfo *duiPtr;
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
if (opnd > 1) {
| > > > > > > > > > > > > > > > > > | > > > | | | > > > > > | < | > > > > > > > > | 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 |
{
int opnd2, allocateDict, done, i, allocdict;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
DictUpdateInfo *duiPtr;
case INST_DICT_VERIFY:
dictPtr = OBJ_AT_TOS;
TRACE(("=> "));
if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n",
O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
case INST_DICT_GET:
case INST_DICT_EXISTS: {
register Tcl_Interp *interp2 = interp;
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) {
goto dictNotExists;
}
TRACE_WITH_OBJ((
"ERROR tracing dictionary path into \"%s\": ",
O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
goto gotError;
}
}
if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
&objResultPtr) == TCL_OK) {
if (*pc == INST_DICT_EXISTS) {
objResultPtr = TCONST(objResultPtr ? 1 : 0);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
}
if (objResultPtr) {
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
}
DECACHE_STACK_INFO();
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"key \"%s\" not known in dictionary",
TclGetString(OBJ_AT_TOS)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
} else {
if (*pc == INST_DICT_EXISTS) {
dictNotExists:
objResultPtr = TCONST(0);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
}
TRACE_WITH_OBJ((
"%u => ERROR reading leaf dictionary key \"%s\": ",
opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
}
goto gotError;
}
case INST_DICT_SET:
case INST_DICT_UNSET:
case INST_DICT_INCR_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
|
| ︙ | ︙ | |||
6300 6301 6302 6303 6304 6305 6306 |
/*
* Division by zero in an expression. Control only reaches this point
* by "goto divideByZero".
*/
divideByZero:
DECACHE_STACK_INFO();
| | > | < | 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 |
/*
* Division by zero in an expression. Control only reaches this point
* by "goto divideByZero".
*/
divideByZero:
DECACHE_STACK_INFO();
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
CACHE_STACK_INFO();
goto gotError;
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
*/
exponOfZero:
DECACHE_STACK_INFO();
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponentiation of zero by negative power", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", NULL);
CACHE_STACK_INFO();
/*
* Almost all error paths feed through here rather than assigning to
* result themselves (for a small but consistent saving).
|
| ︙ | ︙ | |||
6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 |
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
if (--codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
TclStackFree(interp, TD); /* free my stack */
return result;
}
#undef codePtr
#undef iPtr
#undef bcFramePtr
#undef initCatchTop
#undef initTosPtr
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 |
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
if (--codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
TclStackFree(interp, TD); /* free my stack */
return result;
/*
* INST_START_CMD failure case removed where it doesn't bother that much
*
* Remark that if the interpreter is marked for deletion its
* compileEpoch is modified, so that the epoch check also verifies
* that the interp is not deleted. If no outside call has been made
* since the last check, it is safe to omit the check.
* case INST_START_CMD:
*/
instStartCmdFailed:
{
const char *bytes;
checkInterp = 1;
length = 0;
/*
* We used to switch to direct eval; for NRE-awareness we now
* compile and eval the command so that this evaluation does not
* add a new TEBC instance. [Bug 2910748]
*/
if (TclInterpReady(interp) == TCL_ERROR) {
goto gotError;
}
codePtr->flags |= TCL_BYTECODE_RECOMPILE;
bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL);
opnd = TclGetUInt4AtPtr(pc+1);
pc += (opnd-1);
PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
goto instEvalStk;
NEXT_INST_F(9, 0, 0);
}
}
#undef codePtr
#undef iPtr
#undef bcFramePtr
#undef initCatchTop
#undef initTosPtr
|
| ︙ | ︙ | |||
6689 6690 6691 6692 6693 6694 6695 |
mp_clear(&big2);
break;
default:
/* Unused, here to silence compiler warning */
invalid = 0;
}
if (invalid) {
| > | | 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 |
mp_clear(&big2);
break;
default:
/* Unused, here to silence compiler warning */
invalid = 0;
}
if (invalid) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
return GENERAL_ARITHMETIC_ERROR;
}
/*
* Zero shifted any number of bits is still zero.
*/
|
| ︙ | ︙ | |||
6719 6720 6721 6722 6723 6724 6725 | /* * 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 * work, and it takes only an int argument, that's a good * place to draw the line. */ | > | < | 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 | /* * 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 * work, and it takes only an int argument, that's a good * place to draw the line. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } shift = (int)(*((const long *)ptr2)); /* * Handle shifts within the native wide range. */ |
| ︙ | ︙ | |||
7121 7122 7123 7124 7125 7126 7127 |
* 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
* accept.
*/
if (type2 != TCL_NUMBER_LONG) {
| > | | 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 |
* 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
* accept.
*/
if (type2 != TCL_NUMBER_LONG) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
if (type1 == TCL_NUMBER_LONG) {
if (l1 == 2) {
/*
* Reduce small powers of 2 to shifts.
|
| ︙ | ︙ | |||
7359 7360 7361 7362 7363 7364 7365 |
}
#endif
overflowExpon:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (big2.used > 1) {
mp_clear(&big2);
| > | | 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 |
}
#endif
overflowExpon:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (big2.used > 1) {
mp_clear(&big2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
mp_init(&bigResult);
mp_expt_d(&big1, big2.dp[0], &bigResult);
mp_clear(&big1);
mp_clear(&big2);
|
| ︙ | ︙ | |||
7953 7954 7955 7956 7957 7958 7959 |
register 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. */
int stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
| < | | | | | | 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 |
register 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. */
int stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
int stackUpperBound = codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
unsigned relativePc = (unsigned) (pc - codePtr->codeStart);
unsigned long codeStart = (unsigned long) codePtr->codeStart;
unsigned long codeEnd = (unsigned long)
(codePtr->codeStart + codePtr->numCodeBytes);
unsigned char opCode = *pc;
if (((unsigned long) pc < codeStart) || ((unsigned long) 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",
(unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL);
fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
fprintf(stderr,"%s\n", Tcl_GetString(message));
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <sys/stat.h> #include "tclInt.h" #include "tclFileSystem.h" /* * Declarations for local functions defined in this file: */ |
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
* overwriting the symlink.
*/
if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
| | | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
* overwriting the symlink.
*/
if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error %s: target \"%s\" is not a directory",
(copyFlag?"copying":"renaming"), TclGetString(target)));
result = TCL_ERROR;
} else {
/*
* Even though already have target == translated(objv[i+1]), pass
* the original argument down, so if there's an error, the error
* message will reflect the original arguments.
*/
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
}
Tcl_DecrRefCount(split);
split = NULL;
}
done:
if (errfile != NULL) {
| > | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
}
Tcl_DecrRefCount(split);
split = NULL;
}
done:
if (errfile != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create directory \"%s\": %s",
TclGetString(errfile), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
if (split != NULL) {
Tcl_DecrRefCount(split);
}
if (target != NULL) {
Tcl_DecrRefCount(target);
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
* We own a reference count on errorBuffer, if it was set as a
* result of this call.
*/
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
| > | | < | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
* We own a reference count on errorBuffer, if it was set as a
* result of this call.
*/
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error deleting \"%s\": directory not empty",
TclGetString(objv[i])));
Tcl_PosixError(interp);
goto done;
}
/*
* If possible, use the untranslated name for the file.
*/
|
| ︙ | ︙ | |||
422 423 424 425 426 427 428 |
}
if (result != TCL_OK) {
if (errfile == NULL) {
/*
* We try to accomodate poor error results from our Tcl_FS calls.
*/
| > | | > | | < | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
}
if (result != TCL_OK) {
if (errfile == NULL) {
/*
* We try to accomodate poor error results from our Tcl_FS calls.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error deleting unknown file: %s",
Tcl_PosixError(interp)));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error deleting \"%s\": %s",
TclGetString(errfile), Tcl_PosixError(interp)));
}
}
done:
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 |
* implementations of copy and rename on all platforms also prevent
* this.
*/
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
| | | | > | | < | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
* implementations of copy and rename on all platforms also prevent
* this.
*/
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't overwrite file \"%s\" with directory \"%s\"",
TclGetString(target), TclGetString(source)));
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't overwrite directory \"%s\" with file \"%s\"",
TclGetString(target), TclGetString(source)));
goto done;
}
/*
* The destination exists, but appears to be ok to over-write, and
* -force is given. We now try to adjust permissions to ensure the
* operation succeeds. If we can't adjust permissions, we'll let the
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
if (copyFlag == 0) {
result = Tcl_FSRenameFile(source, target);
if (result == TCL_OK) {
goto done;
}
if (errno == EINVAL) {
| | < | | > | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
if (copyFlag == 0) {
result = Tcl_FSRenameFile(source, target);
if (result == TCL_OK) {
goto done;
}
if (errno == EINVAL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error renaming \"%s\" to \"%s\": trying to rename a"
" volume or move a directory into itself",
TclGetString(source), TclGetString(target)));
goto done;
} else if (errno != EXDEV) {
errfile = target;
goto done;
}
/*
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
*/
if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
/*
* Actual file doesn't exist.
*/
| | | > | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
*/
if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
/*
* Actual file doesn't exist.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error copying \"%s\": the target of this link doesn't"
" exist", TclGetString(source)));
goto done;
} else {
int counter = 0;
while (1) {
Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
if (path == NULL) {
|
| ︙ | ︙ | |||
760 761 762 763 764 765 766 |
} else {
result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
| | | > | | > | > | > | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
} else {
result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s",
TclGetString(errfile), Tcl_PosixError(interp)));
errfile = NULL;
}
}
done:
if (errfile != NULL) {
Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"",
(copyFlag ? "copying" : "renaming"), TclGetString(source));
if (errfile != source) {
Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"",
TclGetString(target));
if (errfile != target) {
Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"",
TclGetString(errfile));
}
}
Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp));
Tcl_SetObjResult(interp, errorMsg);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
if (actualSource != NULL) {
Tcl_DecrRefCount(actualSource);
}
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
/*
* There was an error, probably that the filePtr is not
* accepted by any filesystem
*/
| > > | | < | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
/*
* There was an error, probably that the filePtr is not
* accepted by any filesystem
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(filePtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
* We own the object now.
*/
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 |
* Get one attribute.
*/
int index;
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
| | | | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 |
* Get one attribute.
*/
int index;
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
|
| ︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 |
/*
* Set option/value pairs.
*/
int i, index;
if (numObjStrings == 0) {
| | | | | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 |
/*
* Set option/value pairs.
*/
int i, index;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
}
if (attributeStringsAllocated != NULL) {
TclFreeIntRep(objv[i]);
}
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
"NOVALUE", NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
|
| ︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 |
if (contents == NULL) {
/*
* We handle three common error cases specially, and for all other
* errors, we use the standard posix error message.
*/
if (errno == EEXIST) {
| > | | < > | | < > | | | < > | | | < > | | < | 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 |
if (contents == NULL) {
/*
* We handle three common error cases specially, and for all other
* errors, we use the standard posix error message.
*/
if (errno == EEXIST) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\": that path already"
" exists", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else if (errno == ENOENT) {
/*
* There are two cases here: either the target doesn't exist,
* or the directory of the src doesn't exist.
*/
int access;
Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return TCL_ERROR;
}
access = Tcl_FSAccess(dirPtr, F_OK);
Tcl_DecrRefCount(dirPtr);
if (access != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\": no such file"
" or directory", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\": target \"%s\" "
"doesn't exist", TclGetString(objv[index]),
TclGetString(objv[index+1])));
errno = ENOENT;
Tcl_PosixError(interp);
}
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\" pointing to \"%s\": %s",
TclGetString(objv[index]),
TclGetString(objv[index+1]), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
} else {
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/*
* Read link
*/
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read link \"%s\": %s",
TclGetString(objv[index]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 2) {
/*
* If we are reading a link, we need to free this result refCount. If
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 |
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
| > | | | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 |
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read link \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, contents);
Tcl_DecrRefCount(contents);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 |
* Deal with results.
*/
if (chan == NULL) {
if (nameVarObj) {
TclDecrRefCount(nameObj);
}
| | | | | 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
* Deal with results.
*/
if (chan == NULL) {
if (nameVarObj) {
TclDecrRefCount(nameObj);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create temporary file: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
if (nameVarObj != NULL) {
if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_UnregisterChannel(interp, chan);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclFileName.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen native * and network form. * * Copyright (c) 1995-1998 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. */ #include "tclInt.h" #include "tclRegexp.h" #include "tclFileSystem.h" /* For TclGetPathType() */ /* * The following variable is set in the TclPlatformInit call to one of: * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen native * and network form. * * Copyright (c) 1995-1998 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. */ #include <sys/stat.h> #include "tclInt.h" #include "tclRegexp.h" #include "tclFileSystem.h" /* For TclGetPathType() */ /* * The following variable is set in the TclPlatformInit call to one of: * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
SetResultLength(
Tcl_DString *resultPtr,
int offset,
int extended)
{
Tcl_DStringSetLength(resultPtr, offset);
if (extended == 2) {
| | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
SetResultLength(
Tcl_DString *resultPtr,
int offset,
int extended)
{
Tcl_DStringSetLength(resultPtr, offset);
if (extended == 2) {
TclDStringAppendLiteral(resultPtr, "//?/UNC/");
} else if (extended == 1) {
TclDStringAppendLiteral(resultPtr, "//?/");
}
}
/*
*----------------------------------------------------------------------
*
* ExtractWinRoot --
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
const char *host, *share, *tail;
int hlen, slen;
if (path[1] != '/' && path[1] != '\\') {
SetResultLength(resultPtr, offset, extended);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
| | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
const char *host, *share, *tail;
int hlen, slen;
if (path[1] != '/' && path[1] != '\\') {
SetResultLength(resultPtr, offset, extended);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
TclDStringAppendLiteral(resultPtr, "/");
return &path[1];
}
host = &path[2];
/*
* Skip separators.
*/
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 | * page). If there are more than one, we are simply assuming they * are superfluous and we trim them away. (An alternative * interpretation would be that it is a host name, but we have * been documented that that is not the case). */ *typePtr = TCL_PATH_VOLUME_RELATIVE; | | | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
* page). If there are more than one, we are simply assuming they
* are superfluous and we trim them away. (An alternative
* interpretation would be that it is a host name, but we have
* been documented that that is not the case).
*/
*typePtr = TCL_PATH_VOLUME_RELATIVE;
TclDStringAppendLiteral(resultPtr, "/");
return &path[2];
}
SetResultLength(resultPtr, offset, extended);
share = &host[hlen];
/*
* Skip separators.
*/
while (share[0] == '/' || share[0] == '\\') {
share++;
}
for (slen=0; share[slen]; slen++) {
if (share[slen] == '/' || share[slen] == '\\') {
break;
}
}
TclDStringAppendLiteral(resultPtr, "//");
Tcl_DStringAppend(resultPtr, host, hlen);
TclDStringAppendLiteral(resultPtr, "/");
Tcl_DStringAppend(resultPtr, share, slen);
tail = &share[slen];
/*
* Skip separators.
*/
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
while (*tail && (tail[0] == '/' || tail[0] == '\\')) {
tail++;
}
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringAppend(resultPtr, path, 2);
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
while (*tail && (tail[0] == '/' || tail[0] == '\\')) {
tail++;
}
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringAppend(resultPtr, path, 2);
TclDStringAppendLiteral(resultPtr, "/");
return tail;
}
} else {
int abs = 0;
/*
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
case TCL_PLATFORM_UNIX: {
const char *origPath = path;
/*
* Paths that begin with / are absolute.
*/
| > > | | | | < | | | | | > > > > > > | > > > > | | | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
case TCL_PLATFORM_UNIX: {
const char *origPath = path;
/*
* Paths that begin with / are absolute.
*/
if (path[0] == '/') {
++path;
#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
if ((*path == '/') && path[1] && (path[1] != '/')) {
path += 2;
while (*path && *path != '/') {
++path;
}
#if defined(__CYGWIN__)
/* UNC paths need to be followed by a share name */
if (*path++ && (*path && *path != '/')) {
++path;
while (*path && *path != '/') {
++path;
}
} else {
path = origPath + 1;
}
#endif
}
#endif
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the QNX or Cygwin code was used.
*/
*driveNameLengthPtr = (path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
}
break;
}
case TCL_PLATFORM_WINDOWS: {
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
*/
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
| | > > > | | | | > > > > | > > | < | | | | > > | | | > | | < | > | | | | | | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
*/
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
const char *origPath = path, *elementStart;
Tcl_Obj *result = Tcl_NewObj();
/*
* Deal with the root directory as a special case.
*/
if (*path == '/') {
Tcl_Obj *rootElt;
++path;
#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
if ((*path == '/') && path[1] && (path[1] != '/')) {
path += 2;
while (*path && *path != '/') {
++path;
}
#if defined(__CYGWIN__)
/* UNC paths need to be followed by a share name */
if (*path++ && (*path && *path != '/')) {
++path;
while (*path && *path != '/') {
++path;
}
} else {
path = origPath + 1;
}
#endif
}
#endif
rootElt = Tcl_NewStringObj(origPath, path - origPath);
Tcl_ListObjAppendElement(NULL, result, rootElt);
while (*path == '/') {
++path;
}
}
/*
* Split on slashes. Embedded elements that start with tilde will be
* prefixed with "./" so they are not affected by tilde substitution.
*/
for (;;) {
elementStart = path;
while ((*path != '\0') && (*path != '/')) {
path++;
}
length = path - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
if ((elementStart[0] == '~') && (elementStart != origPath)) {
TclNewLiteralStringObj(nextElt, "./");
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*path++ == '\0') {
break;
}
}
return result;
}
/*
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
transPtr = Tcl_FSGetTranslatedPath(interp, path);
if (transPtr == NULL) {
Tcl_DecrRefCount(path);
return NULL;
}
Tcl_DStringInit(bufferPtr);
| | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
transPtr = Tcl_FSGetTranslatedPath(interp, path);
if (transPtr == NULL) {
Tcl_DecrRefCount(path);
return NULL;
}
Tcl_DStringInit(bufferPtr);
TclDStringAppendObj(bufferPtr, transPtr);
Tcl_DecrRefCount(path);
Tcl_DecrRefCount(transPtr);
/*
* Convert forward slashes to backslashes in Windows paths because some
* system interfaces don't accept forward slashes.
*/
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
if (*user == '\0') {
Tcl_DString dirString;
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
| | | | > > | | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
if (*user == '\0') {
Tcl_DString dirString;
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't find HOME environment "
"variable to expand path", -1));
Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL);
}
return NULL;
}
Tcl_JoinPath(1, &dir, resultPtr);
Tcl_DStringFree(&dirString);
} else if (TclpGetUserHome(user, resultPtr) == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", user));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL);
}
return NULL;
}
return Tcl_DStringValue(resultPtr);
}
/*
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 |
i++;
goto endOfForLoop;
}
}
endOfForLoop:
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
| | | | 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 |
i++;
goto endOfForLoop;
}
}
endOfForLoop:
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
separators = NULL; /* lint. */
switch (tclPlatform) {
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
* Need to quote 'prefix'.
*/
Tcl_DStringInit(&prefix);
search = Tcl_DStringValue(&pref);
while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
Tcl_DStringAppend(&prefix, search, find-search);
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
* Need to quote 'prefix'.
*/
Tcl_DStringInit(&prefix);
search = Tcl_DStringValue(&pref);
while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
Tcl_DStringAppend(&prefix, search, find-search);
TclDStringAppendLiteral(&prefix, "\\");
Tcl_DStringAppend(&prefix, find, 1);
search = find+1;
if (*search == '\0') {
break;
}
}
if (*search != '\0') {
|
| ︙ | ︙ | |||
1554 1555 1556 1557 1558 1559 1560 |
result = TCL_OK;
if (join) {
if (dir != PATH_GENERAL) {
Tcl_DStringInit(&prefix);
}
for (i = 0; i < objc; i++) {
| < | | < < | | 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 |
result = TCL_OK;
if (join) {
if (dir != PATH_GENERAL) {
Tcl_DStringInit(&prefix);
}
for (i = 0; i < objc; i++) {
TclDStringAppendObj(&prefix, objv[i]);
if (i != objc -1) {
Tcl_DStringAppend(&prefix, separators, 1);
}
}
if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags,
globTypes) != TCL_OK) {
result = TCL_ERROR;
goto endOfGlob;
}
} else if (dir == PATH_GENERAL) {
Tcl_DString str;
for (i = 0; i < objc; i++) {
Tcl_DStringInit(&str);
if (dir == PATH_GENERAL) {
TclDStringAppendDString(&str, &prefix);
}
TclDStringAppendObj(&str, objv[i]);
if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags,
globTypes) != TCL_OK) {
result = TCL_ERROR;
Tcl_DStringFree(&str);
goto endOfGlob;
}
}
|
| ︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 |
*/
result = TCL_ERROR;
goto endOfGlob;
}
if (length == 0) {
| > | | > | > | < > | | 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 |
*/
result = TCL_ERROR;
goto endOfGlob;
}
if (length == 0) {
Tcl_Obj *errorMsg =
Tcl_ObjPrintf("no files matched glob pattern%s \"",
(join || (objc == 1)) ? "" : "s");
if (join) {
Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1);
} else {
const char *sep = "";
for (i = 0; i < objc; i++) {
Tcl_AppendPrintfToObj(errorMsg, "%s%s",
sep, Tcl_GetString(objv[i]));
sep = " ";
}
}
Tcl_AppendToObj(errorMsg, "\"", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
NULL);
result = TCL_ERROR;
}
}
endOfGlob:
|
| ︙ | ︙ | |||
1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 |
}
pathPrefix = TclDStringToObj(&buffer);
Tcl_IncrRefCount(pathPrefix);
globFlags |= TCL_GLOBMODE_DIR;
if (c != '\0') {
tail++;
}
} else {
tail = pattern;
}
} else {
Tcl_IncrRefCount(pathPrefix);
tail = pattern;
}
| > | 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 |
}
pathPrefix = TclDStringToObj(&buffer);
Tcl_IncrRefCount(pathPrefix);
globFlags |= TCL_GLOBMODE_DIR;
if (c != '\0') {
tail++;
}
Tcl_DStringFree(&buffer);
} else {
tail = pattern;
}
} else {
Tcl_IncrRefCount(pathPrefix);
tail = pattern;
}
|
| ︙ | ︙ | |||
2188 2189 2190 2191 2192 2193 2194 | /* * Balanced braces. */ closeBrace = p; break; } | > | < > | < | 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 |
/*
* Balanced braces.
*/
closeBrace = p;
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched open-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
NULL);
return TCL_ERROR;
} else if (*p == '}') {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched close-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 |
}
switch (tclPlatform) {
case TCL_PLATFORM_WINDOWS:
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
if (((*name == '\\') && (name[1] == '/' ||
name[1] == '\\')) || (*name == '/')) {
| | | | | < < < < < < < < < < < | 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 |
}
switch (tclPlatform) {
case TCL_PLATFORM_WINDOWS:
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
if (((*name == '\\') && (name[1] == '/' ||
name[1] == '\\')) || (*name == '/')) {
TclDStringAppendLiteral(&append, "/");
} else {
TclDStringAppendLiteral(&append, ".");
}
}
break;
case TCL_PLATFORM_UNIX:
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
TclDStringAppendLiteral(&append, "/");
} else {
TclDStringAppendLiteral(&append, ".");
}
}
break;
}
/*
* Common for all platforms.
*/
|
| ︙ | ︙ |
Changes to generic/tclFileSystem.h.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | */ #ifndef _TCLFILESYSTEM #define _TCLFILESYSTEM #include "tcl.h" | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | */ #ifndef _TCLFILESYSTEM #define _TCLFILESYSTEM #include "tcl.h" /* * The internal TclFS API provides routines for handling and manipulating * paths efficiently, taking direct advantage of the "path" Tcl_Obj type. * * These functions are not exported at all at present. */ MODULE_SCOPE int TclFSCwdPointerEquals(Tcl_Obj **pathPtrPtr); MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int startAt); MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, Tcl_Obj *pathPtr); MODULE_SCOPE int TclFSEpoch(void); /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c */ MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem; /* * Private shared functions for use by tclIOUtil.c, tclPathObj.c and * tclFileName.c, and any platform-specific filesystem code. */ MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr, |
| ︙ | ︙ |
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
*/
active = 0;
for (statePtr = tsdPtr->firstCSPtr;
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
| > > > | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 |
*/
active = 0;
for (statePtr = tsdPtr->firstCSPtr;
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
if (GotFlag(statePtr, CHANNEL_DEAD)) {
continue;
}
if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED )
|| GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
active = 1;
break;
}
}
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
static void
CheckForStdChannelsBeingClosed(
Tcl_Channel chan)
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | > > | > > | > > | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
static void
CheckForStdChannelsBeingClosed(
Tcl_Channel chan)
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdinInitialized
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdinChannel = NULL;
return;
}
} else if (tsdPtr->stdoutInitialized
&& tsdPtr->stdoutChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdoutChannel = NULL;
return;
}
} else if (tsdPtr->stderrInitialized
&& tsdPtr->stderrChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stderrChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stderrChannel = NULL;
return;
}
}
}
|
| ︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 |
{
ChannelState *statePtr; /* State of the real channel. */
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp != NULL) {
| > | | | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
{
ChannelState *statePtr; /* State of the real channel. */
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
" of channel", -1));
}
return TCL_ERROR;
}
if (DetachChannel(interp, chan) != TCL_OK) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
1256 1257 1258 1259 1260 1261 1262 |
name = chanPtr->state->channelName;
}
}
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_FindHashEntry(hTblPtr, name);
if (hPtr == NULL) {
| > | < | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
name = chanPtr->state->channelName;
}
}
hTblPtr = GetChannelTable(interp);
hPtr = Tcl_FindHashEntry(hTblPtr, name);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can not find channel named \"%s\"", chanName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL);
return NULL;
}
/*
* Always return bottom-most channel in the stack. This one lives the
* longest - other channels may go away unnoticed. The other APIs
|
| ︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 |
while ((statePtr != NULL) && (statePtr->topChanPtr != prevChanPtr)) {
statePtr = statePtr->nextCSPtr;
}
if (statePtr == NULL) {
if (interp) {
| > | | | | | | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 |
while ((statePtr != NULL) && (statePtr->topChanPtr != prevChanPtr)) {
statePtr = statePtr->nextCSPtr;
}
if (statePtr == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't find state for channel \"%s\"",
Tcl_GetChannelName(prevChan)));
}
return NULL;
}
/*
* Here we check if the given "mask" matches the "flags" of the already
* existing channel.
*
* | - | R | W | RW |
* --+---+---+---+----+ <=> 0 != (chan->mask & prevChan->mask)
* - | | | | |
* R | | + | | + | The superceding channel is allowed to restrict
* W | | | + | + | the capabilities of the superceded one!
* RW| | + | + | + |
* --+---+---+---+----+
*/
if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"reading and writing both disallowed for channel \"%s\"",
Tcl_GetChannelName(prevChan)));
}
return NULL;
}
/*
* Flush the buffers. This ensures that any data still in them at this
* time is not handled by the new transformation. Restrict this to
|
| ︙ | ︙ | |||
1623 1624 1625 1626 1627 1628 1629 |
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
| > | | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 |
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not flush channel \"%s\"",
Tcl_GetChannelName(prevChan)));
}
return NULL;
}
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
}
|
| ︙ | ︙ | |||
1777 1778 1779 1780 1781 1782 1783 |
* Move error messages put by the driver into the chan/ip
* bypass area into the regular interpreter result. Fall back
* to the regular message if nothing was found in the
* bypasses.
*/
if (!TclChanCaughtErrorBypass(interp, chan) && interp) {
| > | | < | 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 |
* Move error messages put by the driver into the chan/ip
* bypass area into the regular interpreter result. Fall back
* to the regular message if nothing was found in the
* bypasses.
*/
if (!TclChanCaughtErrorBypass(interp, chan) && interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not flush channel \"%s\"",
Tcl_GetChannelName((Tcl_Channel) chanPtr)));
}
return TCL_ERROR;
}
statePtr->csPtrR = csPtrR;
statePtr->csPtrW = csPtrW;
}
|
| ︙ | ︙ | |||
2311 2312 2313 2314 2315 2316 2317 |
{
if (!GotFlag(statePtr, CHANNEL_DEAD)) {
return 0;
}
Tcl_SetErrno(EINVAL);
if (interp) {
| > | < | 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 |
{
if (!GotFlag(statePtr, CHANNEL_DEAD)) {
return 0;
}
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to access channel: invalid channel", -1));
}
return 1;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2456 2457 2458 2459 2460 2461 2462 | /* * This used to check for CHANNEL_NONBLOCKING, and panic if * the channel was blocking. However, it appears that setting * stdin to -blocking 0 has some effect on the stdout when * it's a tty channel (dup'ed underneath) */ | | | 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 |
/*
* This used to check for CHANNEL_NONBLOCKING, and panic if
* the channel was blocking. However, it appears that setting
* stdin to -blocking 0 has some effect on the stdout when
* it's a tty channel (dup'ed underneath)
*/
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) {
SetFlag(statePtr, BG_FLUSH_SCHEDULED);
UpdateInterest(chanPtr);
}
errorCode = 0;
break;
}
|
| ︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 |
if (statePtr->refCount > 0) {
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
| > | | | 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 |
if (statePtr->refCount > 0) {
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
" of channel", -1));
}
return TCL_ERROR;
}
SetFlag(statePtr, CHANNEL_INCLOSE);
/*
* When the channel has an escape sequence driven encoding such as
|
| ︙ | ︙ | |||
3203 3204 3205 3206 3207 3208 3209 |
statePtr = chanPtr->state;
/*
* Does the channel support half-close anyway? Error if not.
*/
if (!chanPtr->typePtr->close2Proc) {
| > | | | | < | | | > | | | 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 |
statePtr = chanPtr->state;
/*
* Does the channel support half-close anyway? Error if not.
*/
if (!chanPtr->typePtr->close2Proc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"half-close of channels not supported by %ss",
chanPtr->typePtr->typeName));
return TCL_ERROR;
}
/*
* Is the channel unstacked ? If not we fail.
*/
if (chanPtr != statePtr->topChanPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"half-close not applicable to stack of transformations", -1));
return TCL_ERROR;
}
/*
* Check direction against channel mode. It is an error if we try to close
* a direction not supported by the channel (already closed, or never
* opened for that direction).
*/
if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) {
const char *msg;
if (flags & TCL_CLOSE_READ) {
msg = "read";
} else {
msg = "write";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Half-close of %s-side not possible, side not opened or"
" already closed", msg));
return TCL_ERROR;
}
/*
* A user may try to call half-close from within a channel close
* handler. That won't do.
*/
if (statePtr->flags & CHANNEL_INCLOSE) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
" of channel", -1));
}
return TCL_ERROR;
}
if (flags & TCL_CLOSE_READ) {
/*
* Call the finalization code directly. There are no events to handle,
|
| ︙ | ︙ | |||
4427 4428 4429 4430 4431 4432 4433 |
Tcl_Channel chan, /* Channel from which to read. */
Tcl_DString *lineRead) /* The line read will be appended to this
* DString as UTF-8 characters. The caller
* must have initialized it and is responsible
* for managing the storage. */
{
Tcl_Obj *objPtr;
| | < < | | 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 |
Tcl_Channel chan, /* Channel from which to read. */
Tcl_DString *lineRead) /* The line read will be appended to this
* DString as UTF-8 characters. The caller
* must have initialized it and is responsible
* for managing the storage. */
{
Tcl_Obj *objPtr;
int charsStored;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored > 0) {
TclDStringAppendObj(lineRead, objPtr);
}
TclDecrRefCount(objPtr);
return charsStored;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 |
{
if (interp != NULL) {
const char *genericopt =
"blocking buffering buffersize encoding eofchar translation";
const char **argv;
int argc, i;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
| > | < | > | > | | 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 |
{
if (interp != NULL) {
const char *genericopt =
"blocking buffering buffersize encoding eofchar translation";
const char **argv;
int argc, i;
Tcl_DString ds;
Tcl_Obj *errObj;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
TclDStringAppendLiteral(&ds, " ");
Tcl_DStringAppend(&ds, optionList, -1);
}
if (Tcl_SplitList(interp, Tcl_DStringValue(&ds),
&argc, &argv) != TCL_OK) {
Tcl_Panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
optionName);
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
ckfree(argv);
}
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
7838 7839 7840 7841 7842 7843 7844 |
/*
* If the channel is in the middle of a background copy, fail.
*/
if (statePtr->csPtrR || statePtr->csPtrW) {
if (interp) {
| > | | | 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 |
/*
* If the channel is in the middle of a background copy, fail.
*/
if (statePtr->csPtrR || statePtr->csPtrW) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to set channel options: background copy in"
" progress", -1));
}
return TCL_ERROR;
}
/*
* Disallow options on dead channels -- channels that have been closed but
* not yet been deallocated. Such channels can be found if the exit
|
| ︙ | ︙ | |||
7888 7889 7890 7891 7892 7893 7894 |
ResetFlag(statePtr, CHANNEL_UNBUFFERED);
SetFlag(statePtr, CHANNEL_LINEBUFFERED);
} else if ((newValue[0] == 'n') &&
(strncmp(newValue, "none", len) == 0)) {
ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
SetFlag(statePtr, CHANNEL_UNBUFFERED);
} else if (interp) {
| > | | | 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 |
ResetFlag(statePtr, CHANNEL_UNBUFFERED);
SetFlag(statePtr, CHANNEL_LINEBUFFERED);
} else if ((newValue[0] == 'n') &&
(strncmp(newValue, "none", len) == 0)) {
ResetFlag(statePtr, CHANNEL_LINEBUFFERED);
SetFlag(statePtr, CHANNEL_UNBUFFERED);
} else if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
" full, line, or none", -1));
return TCL_ERROR;
}
return TCL_OK;
} else if (HaveOpt(7, "-buffersize")) {
int newBufferSize;
if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
|
| ︙ | ︙ | |||
7944 7945 7946 7947 7948 7949 7950 |
} else if (argc == 1 || argc == 2) {
int outIndex = (argc - 1);
int inValue = (int) argv[0][0];
int outValue = (int) argv[outIndex][0];
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
| > | | | | | 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 |
} else if (argc == 1 || argc == 2) {
int outIndex = (argc - 1);
int inValue = (int) argv[0][0];
int outValue = (int) argv[outIndex][0];
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
}
ckfree(argv);
return TCL_ERROR;
}
if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = inValue;
}
if (GotFlag(statePtr, TCL_WRITABLE)) {
statePtr->outEofChar = outValue;
}
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
" one, or two elements", -1));
}
ckfree(argv);
return TCL_ERROR;
}
if (argv != NULL) {
ckfree(argv);
}
|
| ︙ | ︙ | |||
7992 7993 7994 7995 7996 7997 7998 |
readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[0] : NULL;
} else if (argc == 2) {
readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
| | | | 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 |
readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[0] : NULL;
} else if (argc == 2) {
readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL;
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
" element list", -1));
}
ckfree(argv);
return TCL_ERROR;
}
if (readMode) {
TclEolTranslation translation;
|
| ︙ | ︙ | |||
8022 8023 8024 8025 8026 8027 8028 |
translation = TCL_TRANSLATE_CR;
} else if (strcmp(readMode, "crlf") == 0) {
translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
| | | | < | 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 |
translation = TCL_TRANSLATE_CR;
} else if (strcmp(readMode, "crlf") == 0) {
translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
ckfree(argv);
return TCL_ERROR;
}
/*
* Reset the EOL flags since we need to look at any buffered data
|
| ︙ | ︙ | |||
8073 8074 8075 8076 8077 8078 8079 |
statePtr->outputTranslation = TCL_TRANSLATE_CR;
} else if (strcmp(writeMode, "crlf") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else if (strcmp(writeMode, "platform") == 0) {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
| | | | < | 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 |
statePtr->outputTranslation = TCL_TRANSLATE_CR;
} else if (strcmp(writeMode, "crlf") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else if (strcmp(writeMode, "platform") == 0) {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
ckfree(argv);
return TCL_ERROR;
}
}
ckfree(argv);
return TCL_OK;
|
| ︙ | ︙ | |||
8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 |
/*
* We must preserve the interpreter so we can report errors on it later.
* Note that we do not need to preserve the channel because that is done
* by Tcl_NotifyChannel before calling channel handlers.
*/
Tcl_Preserve(interp);
result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);
/*
* On error, cause a background error and remove the channel handler and
* the script record.
*
* NOTE: Must delete channel handler before causing the background error
* because the background error may want to reinstall the handler.
*/
if (result != TCL_OK) {
if (chanPtr->typePtr != NULL) {
DeleteScriptRecord(interp, chanPtr, mask);
}
Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FileEventObjCmd --
| > > | 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 |
/*
* We must preserve the interpreter so we can report errors on it later.
* Note that we do not need to preserve the channel because that is done
* by Tcl_NotifyChannel before calling channel handlers.
*/
Tcl_Preserve(interp);
Tcl_Preserve(chanPtr);
result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);
/*
* On error, cause a background error and remove the channel handler and
* the script record.
*
* NOTE: Must delete channel handler before causing the background error
* because the background error may want to reinstall the handler.
*/
if (result != TCL_OK) {
if (chanPtr->typePtr != NULL) {
DeleteScriptRecord(interp, chanPtr, mask);
}
Tcl_BackgroundException(interp, result);
}
Tcl_Release(chanPtr);
Tcl_Release(interp);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FileEventObjCmd --
|
| ︙ | ︙ | |||
8894 8895 8896 8897 8898 8899 8900 |
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
if ((statePtr->flags & mask) == 0) {
| | | | 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 |
chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
if ((statePtr->flags & mask) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s",
(mask == TCL_READABLE) ? "readable" : "writable"));
return TCL_ERROR;
}
/*
* If we are supposed to return the script, do so.
*/
|
| ︙ | ︙ | |||
9016 9017 9018 9019 9020 9021 9022 |
int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0;
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (BUSY_STATE(inStatePtr, TCL_READABLE)) {
if (interp) {
| | | | | | 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 |
int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0;
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (BUSY_STATE(inStatePtr, TCL_READABLE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" is busy", Tcl_GetChannelName(inChan)));
}
return TCL_ERROR;
}
if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" is busy", Tcl_GetChannelName(outChan)));
}
return TCL_ERROR;
}
readFlags = inStatePtr->flags;
writeFlags = outStatePtr->flags;
|
| ︙ | ︙ | |||
10150 10151 10152 10153 10154 10155 10156 |
*
* Note that we cannot have a message in the interpreter bypass
* area, StackSetBlockMode is restricted to the channel bypass.
* We still need the interp as the destination of the move.
*/
if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
| > | | | 10167 10168 10169 10170 10171 10172 10173 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 |
*
* Note that we cannot have a message in the interpreter bypass
* area, StackSetBlockMode is restricted to the channel bypass.
* We still need the interp as the destination of the move.
*/
if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error setting blocking mode: %s",
Tcl_PosixError(interp)));
}
} else {
/*
* TIP #219.
* If we have no interpreter to put a bypass message into we have
* to clear it, to prevent its propagation and use in other places
* unrelated to the actual occurence of the problem.
|
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL);
}
chanObjPtr = tsdPtr->stdoutObjPtr;
}
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
| | | | > | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 |
Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL);
}
chanObjPtr = tsdPtr->stdoutObjPtr;
}
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for writing",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
}
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
* Capture error messages put by the driver into the bypass area and put
* them into the regular interpreter result. Fall back to the regular
* message if nothing was found in the bypass.
*/
error:
if (!TclChanCaughtErrorBypass(interp, chan)) {
| | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
* Capture error messages put by the driver into the bypass area and put
* them into the regular interpreter result. Fall back to the regular
* message if nothing was found in the bypass.
*/
error:
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
| | | | > > | | < | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for writing",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
if (Tcl_Flush(chan) != TCL_OK) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error flushing \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
| | | | > | | | < | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for reading",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
lineLen = -1;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
goto argerror;
}
chanObjPtr = objv[i];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
| | | | > | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
goto argerror;
}
chanObjPtr = objv[i];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for reading",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
i++; /* Consumed channel name. */
/*
* Compute how many bytes to read.
*/
|
| ︙ | ︙ | |||
432 433 434 435 436 437 438 |
* form of the command that is no longer recommended or
* documented. See also [Bug #3151675]. Will be removed in Tcl 9,
* maybe even earlier.
*/
if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
#endif
| | | | | | | | | < | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
* form of the command that is no longer recommended or
* documented. See also [Bug #3151675]. Will be removed in Tcl 9,
* maybe even earlier.
*/
if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
#endif
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected non-negative integer but got \"%s\"",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
#if TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
}
}
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
| > | | < | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error during seek on \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
/*
* Check direction against channel mode. It is an error if we try to
* close a direction not supported by the channel (already closed, or
* never opened for that direction).
*/
if (!(dir & Tcl_GetChannelMode(chan))) {
| | | | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 |
/*
* Check direction against channel mode. It is an error if we try to
* close a direction not supported by the channel (already closed, or
* never opened for that direction).
*/
if (!(dir & Tcl_GetChannelMode(chan))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Half-close of %s-side not possible, side not opened"
" or already closed", dirOptions[index]));
return TCL_ERROR;
}
/*
* Special handling is needed if and only if the channel mode supports
* more than the direction to close. Because if the close the last
* direction suppported we can and will go through the regular
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
| | | | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading output from command: %s",
Tcl_PosixError(interp)));
Tcl_DecrRefCount(resultPtr);
}
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 |
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
| | | | > | 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for reading",
TclGetString(objv[1])));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan)));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
}
ckfree(cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
}
ckfree(cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TcpAcceptCallbacksDeleteProc --
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
| | | | | | | | | | | > | < | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 |
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
async = 1;
break;
case SKT_MYADDR:
a++;
if (a >= objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no argument given for -myaddr option", -1));
return TCL_ERROR;
}
myaddr = TclGetString(objv[a]);
break;
case SKT_MYPORT: {
const char *myPortName;
a++;
if (a >= objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no argument given for -myport option", -1));
return TCL_ERROR;
}
myPortName = TclGetString(objv[a]);
if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {
return TCL_ERROR;
}
break;
}
case SKT_SERVER:
if (async == 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
server = 1;
a++;
if (a >= objc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no argument given for -server option", -1));
return TCL_ERROR;
}
script = TclGetString(objv[a]);
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
}
if (server) {
host = myaddr; /* NULL implies INADDR_ANY */
if (myport != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"option -myport is not valid for servers", -1));
return TCL_ERROR;
}
} else if (a < objc) {
host = TclGetString(objv[a]);
a++;
} else {
Interp *iPtr;
|
| ︙ | ︙ | |||
1595 1596 1597 1598 1599 1600 1601 1602 |
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
}
Tcl_RegisterChannel(interp, chan);
| > | < | 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
}
Tcl_RegisterChannel(interp, chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FcopyObjCmd --
|
| ︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 |
* Parse the channel arguments and verify that they are readable or
* writable, as appropriate.
*/
if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
| | | | > | | | > | 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 |
* Parse the channel arguments and verify that they are readable or
* writable, as appropriate.
*/
if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for reading",
TclGetString(objv[1])));
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for writing",
TclGetString(objv[2])));
return TCL_ERROR;
}
toRead = -1;
cmdPtr = NULL;
for (i = 3; i < objc; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
|
| ︙ | ︙ | |||
1741 1742 1743 1744 1745 1746 1747 |
if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case PENDING_INPUT:
| | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 |
if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case PENDING_INPUT:
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan)));
}
break;
}
return TCL_OK;
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 |
* User is supplying an explicit length.
*/
if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 0) {
| | | | | | < > | | < | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 |
* User is supplying an explicit length.
*/
if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot truncate to negative length of file", -1));
return TCL_ERROR;
}
} else {
/*
* User wants to truncate to the current file position.
*/
length = Tcl_Tell(chan);
if (length == Tcl_WideAsLong(-1)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not determine current location in \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
if (Tcl_TruncateChannel(chan, length) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error during truncate on \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1944 1945 1946 1947 1948 1949 1950 |
* Most commands are plugged directly together, but some are done via
* alias-like rewriting; [chan configure] is this way for security reasons
* (want overwriting of [fconfigure] to control that nicely), and [chan
* names] because the functionality isn't available as a separate command
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
| | | | | | | | | | | > | | | | | | < | | | 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 |
* Most commands are plugged directly together, but some are done via
* alias-like rewriting; [chan configure] is this way for security reasons
* (want overwriting of [fconfigure] to control that nicely), and [chan
* names] because the functionality isn't available as a separate command
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
{"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
{"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
{"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
{"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
{"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
{"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
{"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
{"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char *const extras[] = {
"configure", "::fconfigure",
NULL
};
Tcl_Command ensemble;
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
Tcl_IncrRefCount(dataPtr->command);
ResultInit(&dataPtr->result);
dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
mode, chan);
if (dataPtr->self == NULL) {
| | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
Tcl_IncrRefCount(dataPtr->command);
ResultInit(&dataPtr->result);
dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
mode, chan);
if (dataPtr->self == NULL) {
Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),
"\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan));
Tcl_DecrRefCount(dataPtr->command);
ResultClear(&dataPtr->result);
ckfree(dataPtr);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
400 401 402 403 404 405 406 | static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ | | | | | | | | | | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
ckfree((p)->base.msgStr); \
}
#define PassReceivedErrorInterp(i,p) \
if ((i) != NULL) { \
Tcl_SetChannelErrorInterp((i), \
Tcl_NewStringObj((p)->base.msgStr, -1)); \
} \
FreeReceivedError(p)
#define PassReceivedError(c,p) \
Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
FreeReceivedError(p)
#define ForwardSetStaticError(p,emsg) \
(p)->base.code = TCL_ERROR; \
(p)->base.mustFree = 0; \
(p)->base.msgStr = (char *) (emsg)
#define ForwardSetDynamicError(p,emsg) \
(p)->base.code = TCL_ERROR; \
(p)->base.mustFree = 1; \
(p)->base.msgStr = (char *) (emsg)
static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);
static ReflectedChannelMap * GetThreadReflectedChannelMap(void);
static void DeleteThreadReflectedChannelMap(ClientData clientData);
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 |
Tcl_SetHashValue(hPtr, chan);
#endif
/*
* Return handle as result of command.
*/
| > | | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
Tcl_SetHashValue(hPtr, chan);
#endif
/*
* Return handle as result of command.
*/
Tcl_SetObjResult(interp,
Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
/*
* Signal to ReflectClose to not call 'finalize'.
*/
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
* Posts events to a reflected channel, invokes event handlers. The
* latter implies that arbitrary side effects are possible.
*
*----------------------------------------------------------------------
*/
typedef struct ReflectEvent {
| | | | | > > | | | > > | | < < | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 |
* Posts events to a reflected channel, invokes event handlers. The
* latter implies that arbitrary side effects are possible.
*
*----------------------------------------------------------------------
*/
typedef struct ReflectEvent {
Tcl_Event header;
ReflectedChannel *rcPtr;
int events;
} ReflectEvent;
static int
ReflectEventRun(
Tcl_Event *ev,
int flags)
{
/* OWNER thread
*
* Note: When the channel is closed any pending events of this type are
* deleted. See ReflectClose() for the Tcl_DeleteEvents() calls
* accomplishing that.
*/
ReflectEvent *e = (ReflectEvent *) ev;
Tcl_NotifyChannel(e->rcPtr->chan, e->events);
return 1;
}
static int
ReflectEventDelete(
Tcl_Event *ev,
ClientData cd)
{
/* OWNER thread
*
* Invoked by DeleteThreadReflectedChannelMap() and ReflectClose(). The
* latter ensures that no pending events of this type are run on an
* invalid channel.
*/
ReflectEvent *e = (ReflectEvent *) ev;
if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
return 0;
}
return 1;
}
int
TclChanPostEventObjCmd(
|
| ︙ | ︙ | |||
863 864 865 866 867 868 869 |
chanId = TclGetString(objv[CHAN]);
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);
if (hPtr == NULL) {
| > | < | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 |
chanId = TclGetString(objv[CHAN]);
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can not find reflected channel named \"%s\"", chanId));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL);
return TCL_ERROR;
}
/*
* Note that the search above subsumes several of the older checks, namely:
*
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
}
/*
* Check that the channel is actually interested in the provided events.
*/
if (events & ~rcPtr->interest) {
| | | > | > | > | > | | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
}
/*
* Check that the channel is actually interested in the provided events.
*/
if (events & ~rcPtr->interest) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"tried to post events channel \"%s\" is not interested in",
chanId));
return TCL_ERROR;
}
/*
* We have the channel and the events to post.
*/
#ifdef TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
Tcl_NotifyChannel(chan, events);
#ifdef TCL_THREADS
} else {
ReflectEvent *ev = ckalloc(sizeof(ReflectEvent));
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
/*
* We are not preserving the structure here. When the channel is
* closed any pending events are deleted, see ReflectClose(), and
* ReflectEventDelete(). Trying to preserve and later release when the
* event is run may generate a situation where the channel structure
* is deleted but not our structure, crashing in
* FreeReflectedChannel().
*
* Force creation of the RCM, for proper cleanup on thread teardown.
* The teardown of unprocessed events is currently coupled to the
* thread reflected channel map
*/
(void) GetThreadReflectedChannelMap();
/* XXX Race condition !!
* XXX The destination thread may not exist anymore already.
* XXX (Delayed postevent executed after channel got removed).
* XXX Can we detect this ? (check the validity of the owner threadid ?)
* XXX Actually, in that case the channel should be dead also !
*/
Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(rcPtr->owner);
}
#endif
/*
* Squash interp results left by the event script.
*/
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
#ifdef TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
| > | > > | | | > | > > | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 |
#ifdef TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
/*
* Now squash the pending reflection events for this channel.
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
if (result != TCL_OK) {
FreeReceivedError(&p);
}
}
#endif
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
/*
* -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL)
*
* A cleaned method mask here implies that the channel creation was
* aborted, and "finalize" must not be called.
*/
if (rcPtr->methods == 0) {
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return EOK;
}
/*
* Are we in the correct thread?
*/
#ifdef TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
result = p.base.code;
/*
* Now squash the pending reflection events for this channel.
*/
Tcl_DeleteEvents(ReflectEventDelete, rcPtr);
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
if (result != TCL_OK) {
PassReceivedErrorInterp(interp, &p);
}
} else {
#endif
result = InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj);
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 |
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
#endif
| | | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 |
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
#endif
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
#ifdef TCL_THREADS
}
#endif
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
goto invalid;
}
*errorCodePtr = EOK;
if (bytec > 0) {
| | | 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 |
SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
goto invalid;
}
*errorCodePtr = EOK;
if (bytec > 0) {
memcpy(buf, bytev, (size_t) bytec);
}
stop:
Tcl_DecrRefCount(toReadObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr);
return bytec;
|
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 |
#endif
/* ASSERT: rcPtr->method & FLAG(METH_SEEK) */
Tcl_Preserve(rcPtr);
offObj = Tcl_NewWideIntObj(offset);
| | > | | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 |
#endif
/* ASSERT: rcPtr->method & FLAG(METH_SEEK) */
Tcl_Preserve(rcPtr);
offObj = Tcl_NewWideIntObj(offset);
baseObj = Tcl_NewStringObj(
(seekMode == SEEK_SET) ? "start" :
(seekMode == SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
goto invalid;
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 | * Side effects: * Allocates memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static void | | > > | | 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
* Side effects:
* Allocates memory. Arbitrary, as it calls upon a script.
*
*----------------------------------------------------------------------
*/
static void
ReflectThread(
ClientData clientData,
int action)
{
ReflectedChannel *rcPtr = clientData;
switch (action) {
case TCL_CHANNEL_THREAD_INSERT:
rcPtr->owner = Tcl_GetCurrentThread();
break;
case TCL_CHANNEL_THREAD_REMOVE:
rcPtr->owner = NULL;
break;
default:
Tcl_Panic("Unknown thread action code.");
break;
}
}
#endif
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 |
/*
* The result has to go into the 'dsPtr' for propagation to the caller of
* the driver.
*/
if (optionObj != NULL) {
| | | 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 |
/*
* The result has to go into the 'dsPtr' for propagation to the caller of
* the driver.
*/
if (optionObj != NULL) {
TclDStringAppendObj(dsPtr, resObj);
goto ok;
}
/*
* Extract the list and append each item as element.
*/
|
| ︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 |
(listc == 1 ? "" : "s")));
goto error;
} else {
int len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
| | | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 |
(listc == 1 ? "" : "s")));
goto error;
} else {
int len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
goto ok;
}
ok:
result = TCL_OK;
|
| ︙ | ︙ | |||
2042 2043 2044 2045 2046 2047 2048 |
* list. */
if (Tcl_ListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if (listc < 1) {
| > | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 |
* list. */
if (Tcl_ListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if (listc < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad %s list: is empty", objName));
return TCL_ERROR;
}
events = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], eventOptions,
objName, 0, &evIndex) != TCL_OK) {
|
| ︙ | ︙ | |||
2803 2804 2805 2806 2807 2808 2809 |
/*
* Run over the event queue of this thread and remove all ReflectEvent's
* still pending. These are inbound events for reflected channels this
* thread owns but doesn't handle. The inverse of the channel map
* actually.
*/
| | | 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 |
/*
* Run over the event queue of this thread and remove all ReflectEvent's
* still pending. These are inbound events for reflected channels this
* thread owns but doesn't handle. The inverse of the channel map
* actually.
*/
Tcl_DeleteEvents(ReflectEventDelete, NULL);
/*
* Get the map of all channels handled by the current thread. This is a
* ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
* through the channels, remove all, mark them as dead.
*/
|
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 |
ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
ForwardingResult *resultPtr = evPtr->resultPtr;
ReflectedChannel *rcPtr = evPtr->rcPtr;
Tcl_Interp *interp = rcPtr->interp;
ForwardParam *paramPtr = evPtr->param;
Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
| | < | | 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 |
ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
ForwardingResult *resultPtr = evPtr->resultPtr;
ReflectedChannel *rcPtr = evPtr->rcPtr;
Tcl_Interp *interp = rcPtr->interp;
ForwardParam *paramPtr = evPtr->param;
Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
/*
* Ignore the event if no one is waiting for its result anymore.
*/
if (!resultPtr) {
|
| ︙ | ︙ | |||
3019 3020 3021 3022 3023 3024 3025 | * We remove the channel from both interpreter and thread maps before * releasing the memory, to prevent future accesses (like by * 'postevent') from finding and dereferencing a dangling pointer. */ rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, | | | | 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 |
* We remove the channel from both interpreter and thread maps before
* releasing the memory, to prevent future accesses (like by
* 'postevent') from finding and dereferencing a dangling pointer.
*/
rcmPtr = GetReflectedChannelMap(interp);
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
FreeReflectedChannelArgs(rcPtr);
break;
case ForwardedInput: {
Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead);
|
| ︙ | ︙ | |||
3059 3060 3061 3062 3063 3064 3065 |
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
if (paramPtr->input.toRead < bytec) {
ForwardSetStaticError(paramPtr, msg_read_toomuch);
paramPtr->input.toRead = -1;
} else {
if (bytec > 0) {
| | | | 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 |
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
if (paramPtr->input.toRead < bytec) {
ForwardSetStaticError(paramPtr, msg_read_toomuch);
paramPtr->input.toRead = -1;
} else {
if (bytec > 0) {
memcpy(paramPtr->input.buf, bytev, (size_t) bytec);
}
paramPtr->input.toRead = bytec;
}
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(toReadObj);
break;
}
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->output.buf, paramPtr->output.toWrite);
Tcl_IncrRefCount(bufObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
|
| ︙ | ︙ | |||
3111 3112 3113 3114 3115 3116 3117 |
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedSeek: {
Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset);
Tcl_Obj *baseObj = Tcl_NewStringObj(
| | | | 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 |
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedSeek: {
Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset);
Tcl_Obj *baseObj = Tcl_NewStringObj(
(paramPtr->seek.seekMode==SEEK_SET) ? "start" :
(paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
|
| ︙ | ︙ | |||
3162 3163 3164 3165 3166 3167 3168 |
Tcl_DecrRefCount(maskObj);
Tcl_Release(rcPtr);
break;
}
case ForwardedBlock: {
Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);
| < > | | < > | < | 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 |
Tcl_DecrRefCount(maskObj);
Tcl_Release(rcPtr);
break;
}
case ForwardedBlock: {
Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);
Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL,
&resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(blockObj);
break;
}
case ForwardedSetOpt: {
Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1);
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj,
&resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(optionObj);
Tcl_DecrRefCount(valueObj);
break;
}
case ForwardedGetOpt: {
/*
* Retrieve the value of one option.
*/
Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);
Tcl_IncrRefCount(optionObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
} else {
TclDStringAppendObj(paramPtr->getOpt.value, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(optionObj);
break;
}
case ForwardedGetOptAll:
|
| ︙ | ︙ | |||
3229 3230 3231 3232 3233 3234 3235 | * NOTE (4) as well. */ int listc; Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, resObj, &listc, | | | | 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 |
* NOTE (4) as well.
*/
int listc;
Tcl_Obj **listv;
if (Tcl_ListObjGetElements(interp, resObj, &listc,
&listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
char *buf = ckalloc(200);
sprintf(buf,
"{Expected list with even number of elements, got %d %s instead}",
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
int len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
}
}
}
Tcl_Release(rcPtr);
break;
|
| ︙ | ︙ |
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
359 360 361 362 363 364 365 | static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(ClientData clientData); #define FreeReceivedError(p) \ | > | | | > > | | | | | > > | > | > > | | | > > | | | > < | | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
do { \
if ((p)->base.mustFree) { \
ckfree((p)->base.msgStr); \
} \
} while (0)
#define PassReceivedErrorInterp(i,p) \
do { \
if ((i) != NULL) { \
Tcl_SetChannelErrorInterp((i), \
Tcl_NewStringObj((p)->base.msgStr, -1)); \
} \
FreeReceivedError(p); \
} while (0)
#define PassReceivedError(c,p) \
do { \
Tcl_SetChannelError((c), \
Tcl_NewStringObj((p)->base.msgStr, -1)); \
FreeReceivedError(p); \
} while (0)
#define ForwardSetStaticError(p,emsg) \
do { \
(p)->base.code = TCL_ERROR; \
(p)->base.mustFree = 0; \
(p)->base.msgStr = (char *) (emsg); \
} while (0)
#define ForwardSetDynamicError(p,emsg) \
do { \
(p)->base.code = TCL_ERROR; \
(p)->base.mustFree = 1; \
(p)->base.msgStr = (char *) (emsg); \
} while (0)
static void ForwardSetObjError(ForwardParam *p,
Tcl_Obj *objPtr);
static ReflectedTransformMap * GetThreadReflectedTransformMap(void);
static void DeleteThreadReflectedTransformMap(
ClientData clientData);
#endif /* TCL_THREADS */
#define SetChannelErrorStr(c,msgStr) \
Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1))
static Tcl_Obj * MarshallError(Tcl_Interp *interp);
static void UnmarshallErrorResult(Tcl_Interp *interp,
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
Tcl_Obj *modeObj; /* mode in obj form for method call */
int listc; /* Result of 'initialize', and of */
Tcl_Obj **listv; /* its sublist in the 2nd element */
int methIndex; /* Encoded method name */
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
| < | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
Tcl_Obj *modeObj; /* mode in obj form for method call */
int listc; /* Result of 'initialize', and of */
Tcl_Obj **listv; /* its sublist in the 2nd element */
int methIndex; /* Encoded method name */
int result; /* Result code for 'initialize' */
Tcl_Obj *resObj; /* Result data for 'initialize' */
int methods; /* Bitmask for supported methods. */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
/*
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 |
goto error;
}
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
"method", TCL_EXACT, &methIndex) != TCL_OK) {
| < | | | | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
goto error;
}
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
Tcl_GetString(cmdObj),
Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
}
methods |= FLAG(methIndex);
listc--;
}
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 |
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
}
Tcl_SetHashValue(hPtr, rtPtr);
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
| | > | | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
}
Tcl_SetHashValue(hPtr, rtPtr);
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
#endif /* TCL_THREADS */
/*
* Return the channel as the result of the command.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tcl_GetChannelName(rtPtr->chan), -1));
return TCL_OK;
error:
/*
* We are not going through ReflectClose as we never had a channel
* structure.
*/
Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
return TCL_ERROR;
#undef CHAN
#undef CMD
}
/*
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 |
ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
result = p.base.code;
if (result != TCL_OK) {
FreeReceivedError(&p);
}
}
| | | | | | | | | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
result = p.base.code;
if (result != TCL_OK) {
FreeReceivedError(&p);
}
}
#endif /* TCL_THREADS */
Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
return EOK;
}
/*
* In the reflected channel implementation a cleaned method mask here
* implies that the channel creation was aborted, and "finalize" must not
* be called. for transformations however we are not going through here on
* such an abort, but directly through FreeReflectedTransform. So for us
* that check is not necessary. We always go through 'finalize'.
*/
if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) {
if (!TransformDrain(rtPtr, &errorCode)) {
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
Tcl_EventuallyFree(rtPtr,
(Tcl_FreeProc *) FreeReflectedTransform);
return errorCode;
}
#endif /* TCL_THREADS */
errorCodeSet = 1;
goto cleanup;
}
}
if (HAS(rtPtr->methods, METH_FLUSH)) {
if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
Tcl_EventuallyFree(rtPtr,
(Tcl_FreeProc *) FreeReflectedTransform);
return errorCode;
}
#endif /* TCL_THREADS */
errorCodeSet = 1;
goto cleanup;
}
}
/*
* Are we in the correct thread?
*/
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
result = p.base.code;
Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
if (result != TCL_OK) {
PassReceivedErrorInterp(interp, &p);
return EINVAL;
}
return EOK;
}
#endif /* TCL_THREADS */
/*
* Do the actual invokation of "finalize" now; we're in the right thread.
*/
result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj);
if ((result != TCL_OK) && (interp != NULL)) {
|
| ︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 |
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
| | | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
#endif /* TCL_THREADS */
}
Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL);
}
/*
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
|| HAS(rtPtr->methods, METH_FLUSH))) {
/*
* Neither a tell request, nor clear/flush both not supported. We have
* to go through the Tcl level to clear and/or flush the
* transformation.
*/
| | | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 |
|| HAS(rtPtr->methods, METH_FLUSH))) {
/*
* Neither a tell request, nor clear/flush both not supported. We have
* to go through the Tcl level to clear and/or flush the
* transformation.
*/
if (rtPtr->methods & FLAG(METH_CLEAR)) {
TransformClear(rtPtr);
}
/*
* When flushing the transform for seeking the generated results are
* irrelevant. We cannot put them into the channel, this would move
* the location, throwing it off with regard to where we are and are
|
| ︙ | ︙ | |||
2136 2137 2138 2139 2140 2141 2142 |
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedTransform *rtPtr;
#ifdef TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
| | | 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 |
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedTransform *rtPtr;
#ifdef TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
#endif /* TCL_THREADS */
/*
* Delete all entries. The channels may have been closed already, or will
* be closed later, by the standard IO finalization of an interpreter
* under destruction. Except for the channels which were moved to a
* different interpreter and/or thread. They do not exist from the IO
* systems point of view and will not get closed. Therefore mark all as
|
| ︙ | ︙ | |||
2228 2229 2230 2231 2232 2233 2234 |
resultPtr->result = TCL_ERROR;
ForwardSetStaticError(paramPtr, msg_send_dstlost);
Tcl_ConditionNotify(&resultPtr->done);
}
Tcl_MutexUnlock(&rtForwardMutex);
| < | | 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 |
resultPtr->result = TCL_ERROR;
ForwardSetStaticError(paramPtr, msg_send_dstlost);
Tcl_ConditionNotify(&resultPtr->done);
}
Tcl_MutexUnlock(&rtForwardMutex);
#endif /* TCL_THREADS */
}
#ifdef TCL_THREADS
/*
*----------------------------------------------------------------------
*
* GetThreadReflectedTransformMap --
|
| ︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 |
}
}
Tcl_DecrRefCount(bufObj);
break;
}
| | | 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 |
}
}
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedDrain:
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
|
| ︙ | ︙ | |||
2652 2653 2654 2655 2656 2657 2658 |
paramPtr->transform.buf = ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
| | < | | 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 |
paramPtr->transform.buf = ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
case ForwardedFlush:
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
|
| ︙ | ︙ | |||
2680 2681 2682 2683 2684 2685 2686 |
paramPtr->transform.buf = ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
| | < | < | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 |
paramPtr->transform.buf = ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
case ForwardedClear:
(void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
break;
case ForwardedLimit:
if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->limit.max = -1;
} else if (Tcl_GetIntFromObj(interp, resObj,
¶mPtr->limit.max) != TCL_OK) {
|
| ︙ | ︙ | |||
2791 2792 2793 2794 2795 2796 2797 |
int len;
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
}
| | | 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 |
int len;
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
}
#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
*
* TimerKill --
*
* Timer management. Removes the internal timer if it exists.
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 |
{
rPtr->used = 0;
if (!rPtr->allocated) {
return;
}
| | | 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 |
{
rPtr->used = 0;
if (!rPtr->allocated) {
return;
}
ckfree((char *) rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 |
/*
* Extension of the internal buffer is required.
* NOTE: Currently linear. Should be doubling to amortize.
*/
if (rPtr->allocated == 0) {
rPtr->allocated = toWrite + RB_INCREMENT;
| | | | 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 |
/*
* Extension of the internal buffer is required.
* NOTE: Currently linear. Should be doubling to amortize.
*/
if (rPtr->allocated == 0) {
rPtr->allocated = toWrite + RB_INCREMENT;
rPtr->buf = UCHARP(ckalloc(rPtr->allocated));
} else {
rPtr->allocated += toWrite + RB_INCREMENT;
rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf,
rPtr->allocated));
}
}
/*
* Now copy data.
*/
|
| ︙ | ︙ | |||
3088 3089 3090 3091 3092 3093 3094 |
}
*errorCodePtr = EOK;
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
return 1;
}
| | | 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 |
}
*errorCodePtr = EOK;
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
return 1;
}
#endif /* TCL_THREADS */
/* ASSERT: rtPtr->method & FLAG(METH_READ) */
/* ASSERT: rtPtr->mode & TCL_READABLE */
bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead);
Tcl_IncrRefCount(bufObj);
|
| ︙ | ︙ | |||
3149 3150 3151 3152 3153 3154 3155 |
}
*errorCodePtr = EOK;
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
ckfree(p.transform.buf);
} else
| | | 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 |
}
*errorCodePtr = EOK;
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
ckfree(p.transform.buf);
} else
#endif /* TCL_THREADS */
{
/* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
/* ASSERT: rtPtr->mode & TCL_WRITABLE */
bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
|
| ︙ | ︙ | |||
3211 3212 3213 3214 3215 3216 3217 |
return 0;
}
*errorCodePtr = EOK;
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
} else
| | | 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 |
return 0;
}
*errorCodePtr = EOK;
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
} else
#endif /* TCL_THREADS */
{
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
*errorCodePtr = EINVAL;
return 0;
}
|
| ︙ | ︙ | |||
3266 3267 3268 3269 3270 3271 3272 |
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
} else {
res = 0;
}
ckfree(p.transform.buf);
} else
| | | 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 |
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
} else {
res = 0;
}
ckfree(p.transform.buf);
} else
#endif /* TCL_THREADS */
{
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
*errorCodePtr = EINVAL;
return 0;
}
|
| ︙ | ︙ | |||
3307 3308 3309 3310 3311 3312 3313 |
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p);
return;
}
| | | 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 |
#ifdef TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p);
return;
}
#endif /* TCL_THREADS */
/* ASSERT: rtPtr->method & FLAG(METH_READ) */
/* ASSERT: rtPtr->mode & TCL_READABLE */
(void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
rtPtr->readIsDrained = 0;
|
| ︙ | ︙ |
Changes to generic/tclIOSock.c.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
return TCL_OK;
}
}
if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
return TCL_ERROR;
}
if (*portPtr > 0xFFFF) {
| > | < | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
return TCL_OK;
}
}
if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
return TCL_ERROR;
}
if (*portPtr > 0xFFFF) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't open socket: port number too high", -1));
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
void *sock, /* Socket file descriptor */
int size) /* Minimum buffer size */
{
int current;
socklen_t len;
len = sizeof(int);
| | > | > | > | > | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
void *sock, /* Socket file descriptor */
int size) /* Minimum buffer size */
{
int current;
socklen_t len;
len = sizeof(int);
getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF,
(char *) ¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF,
(char *) &size, len);
}
len = sizeof(int);
getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
(char *) ¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
(char *) &size, len);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
const char **errorMsgPtr) /* Place to store the error message
* detail, if available. */
{
struct addrinfo hints;
struct addrinfo *p;
struct addrinfo *v4head = NULL, *v4ptr = NULL;
struct addrinfo *v6head = NULL, *v6ptr = NULL;
| | < < | < > > > > > > > > > | > > > > | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
const char **errorMsgPtr) /* Place to store the error message
* detail, if available. */
{
struct addrinfo hints;
struct addrinfo *p;
struct addrinfo *v4head = NULL, *v4ptr = NULL;
struct addrinfo *v6head = NULL, *v6ptr = NULL;
char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring;
const char *family = NULL;
Tcl_DString ds;
int result, i;
if (host != NULL) {
native = Tcl_UtfToExternalDString(NULL, host, -1, &ds);
}
/*
* 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;
} else {
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]
*/
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;
}
}
}
hints.ai_socktype = SOCK_STREAM;
#if 0
/*
* 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,
* we'll leave it out for now. After all, it is just an optimisation.
*
* Missing on: OpenBSD, NetBSD.
* Causes failure when used on AIX 5.1 and HP-UX
*/
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
result = getaddrinfo(native, portstring, &hints, addrlist);
if (host != NULL) {
Tcl_DStringFree(&ds);
}
if (result != 0) {
| | > > > > > | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
result = getaddrinfo(native, portstring, &hints, addrlist);
if (host != NULL) {
Tcl_DStringFree(&ds);
}
if (result != 0) {
*errorMsgPtr =
#ifdef EAI_SYSTEM /* Doesn't exist on Windows */
(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
gai_strerror(result);
return 0;
}
/*
* Put IPv4 addresses before IPv6 addresses to maximize backwards
* compatibility of [fconfigure -sockname] output.
*
* There might be more elegant/efficient ways to do this.
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
}
i = 0;
for (p = *addrlist; p != NULL; p = p->ai_next) {
i++;
}
return 1;
| < < < < < < < < < < < < < < < < < < < < < < < < < < < | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
}
i = 0;
for (p = *addrlist; p != NULL; p = p->ai_next) {
i++;
}
return 1;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2001-2004 Vincent Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < > > | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 2001-2004 Vincent Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <sys/stat.h>
#include "tclInt.h"
#ifdef __WIN32__
# include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
/*
* struct FilesystemRecord --
*
* A filesystem record is used to keep track of each filesystem currently
* registered with the core, in a linked list.
*/
typedef struct FilesystemRecord {
ClientData clientData; /* Client specific data for the new 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. */
struct FilesystemRecord *prevPtr;
/* The previous filesystem registered to Tcl,
* or NULL if no more. */
} 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 {
int initialized;
int cwdPathEpoch;
int filesystemEpoch;
Tcl_Obj *cwdPathPtr;
ClientData cwdClientData;
FilesystemRecord *filesystemList;
int claims;
} ThreadSpecificData;
/*
* Prototypes for functions defined later in this file.
*/
static int EvalFileCallback(ClientData data[],
Tcl_Interp *interp, int result);
static FilesystemRecord*FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
Tcl_Obj *pathPtr, const char *pattern,
Tcl_GlobTypeData *types);
static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
static void FsRecacheFilesystemList(void);
static void Claim(void);
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
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
TclpObjCreateDirectory,
TclpObjRemoveDirectory,
TclpObjDeleteFile,
TclpObjCopyFile,
TclpObjRenameFile,
TclpObjCopyDirectory,
TclpObjLstat,
| < | > < | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
TclpObjCreateDirectory,
TclpObjRemoveDirectory,
TclpObjDeleteFile,
TclpObjCopyFile,
TclpObjRenameFile,
TclpObjCopyDirectory,
TclpObjLstat,
/* Needs casts since we're using version_2. */
(Tcl_FSLoadFileProc *) TclpDlopen,
(Tcl_FSGetCwdProc *) TclpGetNativeCwd,
TclpObjChdir
};
/*
* 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.
*/
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
NULL,
NULL
};
/*
* 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.
*/
static int 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.
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
* Used to implement Tcl_FSGetCwd in a file-system independent way.
*/
static Tcl_Obj *cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
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
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
{
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
return NULL;
}
Tcl_DStringInit(cwdPtr);
| | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
{
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
return NULL;
}
Tcl_DStringInit(cwdPtr);
TclDStringAppendObj(cwdPtr, cwd);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
/* Obsolete */
int
Tcl_EvalFile(
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 |
/*
* Trash the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
| | | < > | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
/*
* Trash the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->fsPtr = NULL;
ckfree(fsRecPtr);
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = NULL;
tsdPtr->initialized = 0;
}
int
TclFSCwdIsNative(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (tsdPtr->cwdClientData != NULL) {
return 1;
} else {
return 0;
}
}
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
*----------------------------------------------------------------------
*/
int
TclFSCwdPointerEquals(
Tcl_Obj **pathPtrPtr)
{
| | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
*----------------------------------------------------------------------
*/
int
TclFSCwdPointerEquals(
Tcl_Obj **pathPtrPtr)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
Tcl_MutexLock(&cwdMutex);
if (tsdPtr->cwdPathPtr == NULL
|| tsdPtr->cwdPathEpoch != cwdPathEpoch) {
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
return 1;
} else {
return 0;
}
}
}
| < | | | | < < < < < > > | < | > | | > > | > > > > > < | < < < < < < < | | < < | < < > > > > > > | > > | > > > > > > > > > > > > > | > | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
return 1;
} else {
return 0;
}
}
}
static void
FsRecacheFilesystemList(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list;
/*
* Trash the current cache.
*/
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->nextPtr = toFree;
toFree = fsRecPtr;
fsRecPtr = tmpFsRecPtr;
}
/*
* Locate tail of the global filesystem list.
*/
Tcl_MutexLock(&filesystemMutex);
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
/*
* Refill the cache honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
list = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
tsdPtr->filesystemList = list;
tsdPtr->filesystemEpoch = theFilesystemEpoch;
Tcl_MutexUnlock(&filesystemMutex);
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
toFree->fsPtr = NULL;
ckfree(toFree);
toFree = next;
}
/*
* Make sure the above gets released on thread exit.
*/
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
tsdPtr->initialized = 1;
}
}
static FilesystemRecord *
FsGetFirstFilesystem(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (tsdPtr->filesystemList == NULL || ((tsdPtr->claims == 0)
&& (tsdPtr->filesystemEpoch != theFilesystemEpoch))) {
FsRecacheFilesystemList();
}
return tsdPtr->filesystemList;
}
/*
* The epoch can be changed both by filesystems being added or removed and by
* env(HOME) changing.
*/
int
TclFSEpochOk(
int filesystemEpoch)
{
return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch);
}
static void
Claim(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
tsdPtr->claims++;
}
static void
Disclaim(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
tsdPtr->claims--;
}
int
TclFSEpoch(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
return tsdPtr->filesystemEpoch;
}
/*
* If non-NULL, clientData is owned by us and must be freed later.
*/
static void
FsUpdateCwd(
Tcl_Obj *cwdObj,
ClientData clientData)
{
int len;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 |
* needed.
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
| < < | < | | < > | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
* needed.
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
/* The native filesystem is static, so we don't free it. */
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree(fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
theFilesystemEpoch++;
filesystemList = NULL;
/*
* Now filesystemList is NULL. This means that any attempt to use the
* filesystem is likely to fail.
*/
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
*----------------------------------------------------------------------
*/
void
TclResetFilesystem(void)
{
filesystemList = &nativeFilesystemRecord;
| | < < < < | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
*----------------------------------------------------------------------
*/
void
TclResetFilesystem(void)
{
filesystemList = &nativeFilesystemRecord;
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.
*/
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
}
newFilesystemPtr = ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
| < < < < < < < | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 |
}
newFilesystemPtr = 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
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
/*
* 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.
*/
fsRecPtr = filesystemList;
| | < < | < | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
/*
* 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.
*/
fsRecPtr = filesystemList;
while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
if (fsRecPtr->fsPtr == fsPtr) {
if (fsRecPtr->prevPtr) {
fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
} else {
filesystemList = fsRecPtr->nextPtr;
}
if (fsRecPtr->nextPtr) {
fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
}
/*
* 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).
*/
theFilesystemEpoch++;
ckfree(fsRecPtr);
retVal = TCL_OK;
} else {
fsRecPtr = fsRecPtr->nextPtr;
}
}
|
| ︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 |
* single filesystem's implementation of Tcl_FSMatchInDirectory will have
* to deal with it for us.
*/
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
| | | > | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 |
* single filesystem's implementation of Tcl_FSMatchInDirectory will have
* to deal with it for us.
*/
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"glob couldn't determine the current working directory",
-1));
}
return TCL_ERROR;
}
fsPtr = Tcl_FSGetFileSystemForPath(cwd);
if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {
TclNewObj(tmpResultPtr);
|
| ︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 |
* 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).
*/
firstFsRecPtr = FsGetFirstFilesystem();
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
continue;
}
/*
* TODO: Assume that we always find the native file system; it should
| > | 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 |
* 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).
*/
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
continue;
}
/*
* TODO: Assume that we always find the native file system; it should
|
| ︙ | ︙ | |||
1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 |
/*
* We could add an efficiency check like this:
* if (retVal == length-of(pathPtr)) {break;}
* but there's not much benefit.
*/
}
return startAt;
}
/*
*---------------------------------------------------------------------------
*
| > | 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 |
/*
* We could add an efficiency check like this:
* if (retVal == length-of(pathPtr)) {break;}
* but there's not much benefit.
*/
}
Disclaim();
return startAt;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1537 1538 1539 1540 1541 1542 1543 |
}
return mode;
error:
*seekFlagPtr = 0;
*binaryPtr = 0;
if (interp != NULL) {
| | | | 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 |
}
return mode;
error:
*seekFlagPtr = 0;
*binaryPtr = 0;
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"illegal access mode \"%s\"", modeString));
}
return -1;
}
/*
* The access modes are specified using a list of POSIX modes such as
* O_CREAT.
|
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 |
mode |= O_EXCL;
} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
mode |= O_NOCTTY;
#else
if (interp != NULL) {
| | | > | | > | | | > | | > | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 |
mode |= O_EXCL;
} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
mode |= O_NOCTTY;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
ckfree(modeArgv);
return -1;
#endif
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#ifdef O_NONBLOCK
mode |= O_NONBLOCK;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
ckfree(modeArgv);
return -1;
#endif
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
mode |= O_TRUNC;
} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
*binaryPtr = 1;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid access mode \"%s\": must be RDONLY, WRONLY, "
"RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK,"
" or TRUNC", flag));
}
ckfree(modeArgv);
return -1;
}
}
ckfree(modeArgv);
if (!gotRW) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"access mode must include either RDONLY, WRONLY, or RDWR",
-1));
}
return -1;
}
return mode;
}
/*
|
| ︙ | ︙ | |||
1686 1687 1688 1689 1690 1691 1692 |
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return result;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
| > | | | | | | 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 |
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return result;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
/*
* The eofchar is \32 (^Z). This is the usual on Windows, but we effect
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
|
| ︙ | ︙ | |||
1728 1729 1730 1731 1732 1733 1734 |
/*
* Try to read first character of stream, so we can check for utf-8 BOM to
* be handled especially.
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
| > | | > | | | 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
/*
* Try to read first character of stream, so we can check for utf-8 BOM to
* be handled especially.
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
string = Tcl_GetString(objPtr);
/*
* 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) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
goto end;
}
|
| ︙ | ︙ | |||
1817 1818 1819 1820 1821 1822 1823 |
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
| > | | | | | | 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 |
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
/*
* The eofchar is \32 (^Z). This is the usual on Windows, but we effect
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 |
/*
* Try to read first character of stream, so we can check for utf-8 BOM to
* be handled especially.
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
| > | | > | | | 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 |
/*
* Try to read first character of stream, so we can check for utf-8 BOM to
* be handled especially.
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
string = Tcl_GetString(objPtr);
/*
* 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) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 |
/*
* Apply appropriate flags parsed out above.
*/
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
< (Tcl_WideInt) 0) {
if (interp != NULL) {
| | | | > | | | 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 |
/*
* Apply appropriate flags parsed out above.
*/
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
< (Tcl_WideInt) 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not seek to end of file while opening \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
Tcl_Close(NULL, retVal);
return NULL;
}
if (binary) {
Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
}
return retVal;
}
/*
* File doesn't belong to any filesystem that can open it.
*/
Tcl_SetErrno(ENOENT);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2587 2588 2589 2590 2591 2592 2593 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSGetCwd(
Tcl_Interp *interp)
{
| | | > | | 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSGetCwd(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (TclFSCwdPointerEquals(NULL)) {
FilesystemRecord *fsRecPtr;
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.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
for (; (retVal == NULL) && (fsRecPtr != NULL);
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
|
| ︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 2652 2653 |
FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
} else {
fsRecPtr->fsPtr->freeInternalRepProc(retCd);
}
Tcl_DecrRefCount(retVal);
retVal = NULL;
goto cdDidNotChange;
} else if (interp != NULL) {
| > | | | > | 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
} else {
fsRecPtr->fsPtr->freeInternalRepProc(retCd);
}
Tcl_DecrRefCount(retVal);
retVal = NULL;
Disclaim();
goto cdDidNotChange;
} else if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
}
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
|
| ︙ | ︙ | |||
2722 2723 2724 2725 2726 2727 2728 |
* New API.
*/
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
retCd = proc2(tsdPtr->cwdClientData);
if (retCd == NULL && interp != NULL) {
| | | | | 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 |
* New API.
*/
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
retCd = proc2(tsdPtr->cwdClientData);
if (retCd == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
if (retCd == tsdPtr->cwdClientData) {
goto cdDidNotChange;
}
/*
|
| ︙ | ︙ | |||
2935 2936 2937 2938 2939 2940 2941 | * 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. */ | | | 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 | * 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. */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); ClientData cd; ClientData oldcd = tsdPtr->cwdClientData; /* * Assumption we are using a filesystem version 2. */ |
| ︙ | ︙ | |||
3066 3067 3068 3069 3070 3071 3072 |
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. */
| | | 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 |
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. */
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 **procPtrs = (void **) procVPtrs;
|
| ︙ | ︙ | |||
3091 3092 3093 3094 3095 3096 3097 |
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (fsPtr->loadFileProc != NULL) {
| | | | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 |
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (fsPtr->loadFileProc != NULL) {
int retVal = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc))
(interp, pathPtr, handlePtr, &unloadProcPtr, flags);
if (retVal == TCL_OK) {
if (*handlePtr == NULL) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
goto resolveSymbols;
|
| ︙ | ︙ | |||
3114 3115 3116 3117 3118 3119 3120 |
* The filesystem doesn't support 'load', so we fall back on the following
* technique:
*
* First check if it is readable -- and exists!
*/
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
| > | | | 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 |
* The filesystem doesn't support 'load', so we fall back on the following
* technique:
*
* First check if it is readable -- and exists!
*/
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load library \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
#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
|
| ︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 |
if (!buffer) {
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
ret = Tcl_Read(data, buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
| | | > | < | 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 |
if (!buffer) {
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
ret = Tcl_Read(data, buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
&unloadProcPtr, flags);
if (ret == TCL_OK && *handlePtr != NULL) {
goto resolveSymbols;
}
}
mustCopyToTempAnyway:
Tcl_ResetResult(interp);
#endif /* TCL_LOAD_FROM_MEMORY */
/*
* Get a temporary filename to use, first to copy the file into, and then
* to load.
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
Tcl_IncrRefCount(copyToPtr);
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_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't load from current filesystem", -1));
return TCL_ERROR;
}
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
/*
* Cross-platform copy failed.
*/
|
| ︙ | ︙ | |||
3228 3229 3230 3231 3232 3233 3234 |
/*
* We need to reset the result now, because the cross-filesystem copy may
* have stored the number of bytes in the result.
*/
Tcl_ResetResult(interp);
| | | 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 |
/*
* We need to reset the result now, because the cross-filesystem copy may
* have stored the number of bytes in the result.
*/
Tcl_ResetResult(interp);
retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs,
&newLoadHandle);
if (retVal != TCL_OK) {
/*
* The file didn't load successfully.
*/
Tcl_FSDeleteFile(copyToPtr);
|
| ︙ | ︙ | |||
3458 3459 3460 3461 3462 3463 3464 |
Tcl_DecrRefCount(tvdlPtr->divertedFile);
}
ckfree(tvdlPtr);
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 |
Tcl_DecrRefCount(tvdlPtr->divertedFile);
}
ckfree(tvdlPtr);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindSymbol --
*
* Find a symbol in a loaded library
|
| ︙ | ︙ | |||
3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 |
* 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.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr->listVolumesProc != NULL) {
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
Tcl_DecrRefCount(thisFsVolumes);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
| > > | 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 |
* 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.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr->listVolumesProc != NULL) {
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
Tcl_DecrRefCount(thisFsVolumes);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
Disclaim();
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 |
* 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.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
}
fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr,
pattern, &mountsOnly);
}
fsRecPtr = fsRecPtr->nextPtr;
}
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
| > > | 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 |
* 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.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
}
fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr,
pattern, &mountsOnly);
}
fsRecPtr = fsRecPtr->nextPtr;
}
Disclaim();
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 |
/*
* 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).
*/
fsRecPtr = FsGetFirstFilesystem();
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)
| > | 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 |
/*
* 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).
*/
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)
|
| ︙ | ︙ | |||
4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 |
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return type;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSRenameFile --
| > | 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 |
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
Disclaim();
return type;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSRenameFile --
|
| ︙ | ︙ | |||
4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 |
* 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.
*/
fsRecPtr = FsGetFirstFilesystem();
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
return NULL;
} else if (retVal != NULL) {
/* TODO: Can this happen? */
return retVal;
}
/*
* Call each of the "pathInFilesystem" functions in succession. A
* non-return value of -1 indicates the particular function has succeeded.
*/
| > > > > | 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 |
* 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.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
Disclaim();
return NULL;
} else if (retVal != NULL) {
/* TODO: Can this happen? */
Disclaim();
return retVal;
}
/*
* Call each of the "pathInFilesystem" functions in succession. A
* non-return value of -1 indicates the particular function has succeeded.
*/
|
| ︙ | ︙ | |||
4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 |
if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) {
/*
* We assume the type of pathPtr hasn't been changed by the above
* call to the pathInFilesystemProc.
*/
TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData);
return fsRecPtr->fsPtr;
}
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
| > > | 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 |
if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) {
/*
* We assume the type of pathPtr hasn't been changed by the above
* call to the pathInFilesystemProc.
*/
TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData);
Disclaim();
return fsRecPtr->fsPtr;
}
}
Disclaim();
return NULL;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
| | > > > > | < < | | > | > > | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count = 0;
TclNewObj(resultPtr);
entryPtr = tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
msg, " \"", key, NULL);
if (*entryPtr == NULL) {
Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
} else {
Tcl_AppendStringsToObj(resultPtr, "\": must be ",
*entryPtr, NULL);
entryPtr = NEXT_ENTRY(entryPtr, offset);
while (*entryPtr != NULL) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
" or ", *entryPtr, NULL);
} else if (**entryPtr) {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
count++;
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 |
*/
Tcl_Command
TclInitPrefixCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap prefixImplMap[] = {
| | | | | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
*/
Tcl_Command
TclInitPrefixCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap prefixImplMap[] = {
{"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
Tcl_Command prefixCmd;
prefixCmd = TclMakeEnsemble(interp, "::tcl::prefix", prefixImplMap);
Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
"prefix", 0);
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
return TCL_ERROR;
}
switch ((enum matchOptions) index) {
case PRFMATCH_EXACT:
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
| | | > | > | | > | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
return TCL_ERROR;
}
switch ((enum matchOptions) index) {
case PRFMATCH_EXACT:
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
message = Tcl_GetString(objv[i]);
break;
case PRFMATCH_ERROR:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
result = Tcl_ListObjLength(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error options must have an even number of elements",
-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
errorPtr = objv[i];
break;
}
}
|
| ︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 |
continue;
}
if (infoPtr->keyStr[length] == 0) {
matchPtr = infoPtr;
goto gotMatch;
}
if (matchPtr != NULL) {
| > | < > | < | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
continue;
}
if (infoPtr->keyStr[length] == 0) {
matchPtr = infoPtr;
goto gotMatch;
}
if (matchPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"ambiguous option \"%s\"", str));
goto error;
}
matchPtr = infoPtr;
}
if (matchPtr == NULL) {
/*
* Unrecognized argument. Just copy it down, unless the caller
* prefers an error to be registered.
*/
if (remObjv == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unrecognized argument \"%s\"", str));
goto error;
}
dstIndex++; /* This argument is now handled */
leftovers[nrem++] = curArg;
continue;
}
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
break;
case TCL_ARGV_INT:
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
| | | | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
break;
case TCL_ARGV_INT:
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer argument for \"%s\" but got \"%s\"",
infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
objc--;
break;
case TCL_ARGV_STRING:
if (objc == 0) {
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 |
goto argsDone;
case TCL_ARGV_FLOAT:
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
| > | < | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 |
goto argsDone;
case TCL_ARGV_FLOAT:
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected floating-point argument for \"%s\" but got \"%s\"",
infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
objc--;
break;
case TCL_ARGV_FUNC: {
Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
/*
* Make sure to handle freeing any temporary space we've allocated on the
* way to an error.
*/
missingArg:
| | | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 |
/*
* Make sure to handle freeing any temporary space we've allocated on the
* way to an error.
*/
missingArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" option requires an additional argument", str));
error:
if (leftovers != NULL) {
ckfree(leftovers);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
* descriptions. */
{
register const Tcl_ArgvInfo *infoPtr;
int width, numSpaces;
#define NUM_SPACES 20
static const char spaces[] = " ";
char tmp[TCL_DOUBLE_SPACE];
/*
* First, compute the width of the widest option key, so that we can make
* everything line up.
*/
width = 4;
| > | 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 |
* descriptions. */
{
register const Tcl_ArgvInfo *infoPtr;
int width, numSpaces;
#define NUM_SPACES 20
static const char spaces[] = " ";
char tmp[TCL_DOUBLE_SPACE];
Tcl_Obj *msg;
/*
* First, compute the width of the widest option key, so that we can make
* everything line up.
*/
width = 4;
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
}
}
/*
* Now add the option information, with pretty-printing.
*/
| | | | | | | > | < > > < | < | | > | | | | | | > | | > | < < | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 |
}
}
/*
* Now add the option information, with pretty-printing.
*/
msg = Tcl_NewStringObj("Command-specific options:", -1);
for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
continue;
}
Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr);
numSpaces = width + 1 - strlen(infoPtr->keyStr);
while (numSpaces > 0) {
if (numSpaces >= NUM_SPACES) {
Tcl_AppendToObj(msg, spaces, NUM_SPACES);
} else {
Tcl_AppendToObj(msg, spaces, numSpaces);
}
numSpaces -= NUM_SPACES;
}
Tcl_AppendToObj(msg, infoPtr->helpStr, -1);
switch (infoPtr->type) {
case TCL_ARGV_INT:
Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
*((int *) infoPtr->dstPtr));
break;
case TCL_ARGV_FLOAT:
Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g",
*((double *) infoPtr->dstPtr));
sprintf(tmp, "%g", *((double *) infoPtr->dstPtr));
break;
case TCL_ARGV_STRING: {
char *string = *((char **) infoPtr->dstPtr);
if (string != NULL) {
Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"",
string);
}
break;
}
default:
break;
}
}
Tcl_SetObjResult(interp, msg);
}
/*
*----------------------------------------------------------------------
*
* TclGetCompletionCodeFromObj --
*
* Parses Completion code Code
*
* Results:
* Returns TCL_ERROR if the value is an invalid completion code.
* Otherwise, returns TCL_OK, and writes the completion code to the
* pointer provided.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGetCompletionCodeFromObj(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *value,
int *codePtr) /* Argument objects. */
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
if ((value->typePtr != &indexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT,
codePtr) == TCL_OK) {
return TCL_OK;
}
/*
* Value is not a legal completion code.
*/
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad completion code \"%s\": must be"
" ok, error, return, break, continue, or an integer",
TclGetString(value)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
}
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
| | | | < > | | < > | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 |
declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
# TIP 338 made these public - now declared in tcl.h too
declare 178 {
void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
declare 179 {
Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
}
# REMOVED
# Allocate lists without copying arrays
# declare 180 {
# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
# }
#declare 181 {
|
| ︙ | ︙ | |||
937 938 939 940 941 942 943 |
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
# TIP 337 made this one public
| | | < > | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
# TIP 337 made this one public
declare 236 {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
# TIP #285: Script cancellation support.
declare 237 {
int TclResetCancellation(Tcl_Interp *interp, int force)
}
# NRE functions for "rogue" extensions to exploit NRE; they will need to
|
| ︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
# Signature changed in 8.1:
# declare 16 win {
# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
# declare 17 win {
# char *TclpGetTZName(void)
# }
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
| > > > > > | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
# Signature changed in 8.1:
# declare 16 win {
# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
# declare 17 win {
# char *TclpGetTZName(void)
# }
# new for 8.5.12+ Cygwin only
declare 17 win {
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
|
| ︙ | ︙ | |||
1139 1140 1141 1142 1143 1144 1145 |
}
# Added in 8.4.2
declare 28 win {
void TclWinResetInterfaces(void)
}
| < < < | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
}
# Added in 8.4.2
declare 28 win {
void TclWinResetInterfaces(void)
}
################################
# Unix specific functions
# Pipe channel functions
declare 0 unix {
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 |
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
declare 19 macosx {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
| > | > > > > > > > | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
declare 19 macosx {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
declare 29 {win unix} {
int TclWinCPUID(unsigned int index, unsigned int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
797 798 799 800 801 802 803 |
#define TclClearVarTraceActive(varPtr) \
(varPtr)->flags &= ~VAR_TRACE_ACTIVE
#define TclSetVarNamespaceVar(varPtr) \
if (!TclIsVarNamespaceVar(varPtr)) {\
(varPtr)->flags |= VAR_NAMESPACE_VAR;\
| > | > > | > | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 |
#define TclClearVarTraceActive(varPtr) \
(varPtr)->flags &= ~VAR_TRACE_ACTIVE
#define TclSetVarNamespaceVar(varPtr) \
if (!TclIsVarNamespaceVar(varPtr)) {\
(varPtr)->flags |= VAR_NAMESPACE_VAR;\
if (TclIsVarInHash(varPtr)) {\
((VarInHash *)(varPtr))->refCount++;\
}\
}
#define TclClearVarNamespaceVar(varPtr) \
if (TclIsVarNamespaceVar(varPtr)) {\
(varPtr)->flags &= ~VAR_NAMESPACE_VAR;\
if (TclIsVarInHash(varPtr)) {\
((VarInHash *)(varPtr))->refCount--;\
}\
}
/*
* Macros to read various flag bits of variables.
* The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE int TclIsVarScalar(Var *varPtr);
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
* sets it, and it should only ever be set by
* the code that is pushing the frame. In that
* case, the code that sets it should also
* have some means of discovering what the
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
| | | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 |
* sets it, and it should only ever be set by
* the code that is pushing the frame. In that
* case, the code that sets it should also
* have some means of discovering what the
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
Tcl_Obj *tailcallPtr;
/* NULL if no tailcall is scheduled */
} CallFrame;
#define FRAME_IS_PROC 0x1
#define FRAME_IS_LAMBDA 0x2
#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
* clientData field contains a CallContext
|
| ︙ | ︙ | |||
2242 2243 2244 2245 2246 2247 2248 | * code other than TCL_OK or TCL_ERROR; 0 means codes * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 4 #define TCL_EVAL_FILE 2 #define TCL_EVAL_CTX 8 | < | 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 | * code other than TCL_OK or TCL_ERROR; 0 means codes * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 4 #define TCL_EVAL_FILE 2 #define TCL_EVAL_CTX 8 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of |
| ︙ | ︙ | |||
2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 |
(((listPtr)->typePtr == &tclListType) \
? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
: Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
#define TclListObjIsCanonical(listPtr) \
(((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
/*
* Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere,
* Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints.
*
* WARNING: these macros eval their args more than once.
*/
| > > > > > > > > | 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 |
(((listPtr)->typePtr == &tclListType) \
? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
: Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
#define TclListObjIsCanonical(listPtr) \
(((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
* TclNRLmapCmd and their compilations.
*/
#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
* Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere,
* Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints.
*
* WARNING: these macros eval their args more than once.
*/
|
| ︙ | ︙ | |||
2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 | * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); /* * The following types are used for getting and storing platform-specific file * attributes in tclFCmd.c and the various platform-versions of that file. * This is done to have as much common code as possible in the file attributes * code. For more information about the callbacks, see TclFileAttrsCmd in * tclFCmd.c. | > > | 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 | * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file * attributes in tclFCmd.c and the various platform-versions of that file. * This is done to have as much common code as possible in the file attributes * code. For more information about the callbacks, see TclFileAttrsCmd in * tclFCmd.c. |
| ︙ | ︙ | |||
2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 | MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; | > > > | > | > > > | 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 | MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); /* These two can be considered for the public api */ MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); /* * This structure holds the data for the various iteration callbacks used to * NRE the 'for' and 'while' commands. We need a separate structure because we * have more than the 4 client data entries we can provide directly thorugh * the callback API. It is the 'word' information which puts us over the * limit. It is needed because the loop body is argument 4 of 'for' and |
| ︙ | ︙ | |||
2860 2861 2862 2863 2864 2865 2866 | *---------------------------------------------------------------- */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, int len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); | < | 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 | *---------------------------------------------------------------- */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, int len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, int loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, |
| ︙ | ︙ | |||
2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 | MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); MODULE_SCOPE void TclFinalizeEvaluation(void); | > > > > | 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 | MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); MODULE_SCOPE void TclFinalizeEvaluation(void); |
| ︙ | ︙ | |||
3061 3062 3063 3064 3065 3066 3067 | int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); | < < < < < < | 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 | int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); MODULE_SCOPE void TclpMasterUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); |
| ︙ | ︙ | |||
3145 3146 3147 3148 3149 3150 3151 | const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); 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, Tcl_LoadHandle *loadHandle, | | | | 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 | const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); 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, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, int size, int codeSize, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); #endif MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); |
| ︙ | ︙ | |||
3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); | > > > | 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); |
| ︙ | ︙ | |||
3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 | *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(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); MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > > > > > > > > > > > > > > > > > > > > > > | 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 | *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(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); MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
| ︙ | ︙ | |||
3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, |
| ︙ | ︙ | |||
3899 3900 3901 3902 3903 3904 3905 | * The PURIFY mode is like the regular mode, but instead of doing block * Tcl_Obj allocation and keeping a freed list for efficiency, it always * allocates and frees a single Tcl_Obj so that tools like Purify can better * track memory leaks. */ # define TclAllocObjStorageEx(interp, objPtr) \ | | > | 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 | * The PURIFY mode is like the regular mode, but instead of doing block * Tcl_Obj allocation and keeping a freed list for efficiency, it always * allocates and frees a single Tcl_Obj so that tools like Purify can better * track memory leaks. */ # define TclAllocObjStorageEx(interp, objPtr) \ (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ ckfree((char *) (objPtr)) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC #elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from * per-thread caches. */ |
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 |
/*
* The sLiteral argument *must* be a string literal; the incantation with
* sizeof(sLiteral "") will fail to compile otherwise.
*/
#define TclNewLiteralStringObj(objPtr, sLiteral) \
TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
* The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE int TclIsInfinite(double d);
* MODULE_SCOPE int TclIsNaN(double d);
| > > > > > > > > > > > > > > > | 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 |
/*
* The sLiteral argument *must* be a string literal; the incantation with
* sizeof(sLiteral "") will fail to compile otherwise.
*/
#define TclNewLiteralStringObj(objPtr, sLiteral) \
TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
/*
*----------------------------------------------------------------
* Convenience macros for DStrings.
* The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr,
* const char *sLiteral);
* MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr);
*/
#define TclDStringAppendLiteral(dsPtr, sLiteral) \
Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
#define TclDStringClear(dsPtr) \
Tcl_DStringSetLength((dsPtr), 0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
* The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE int TclIsInfinite(double d);
* MODULE_SCOPE int TclIsNaN(double d);
|
| ︙ | ︙ | |||
4647 4648 4649 4650 4651 4652 4653 |
callbackPtr->data[1] = (ClientData)(data1); \
callbackPtr->data[2] = (ClientData)(data2); \
callbackPtr->data[3] = (ClientData)(data3); \
callbackPtr->nextPtr = TOP_CB(interp); \
TOP_CB(interp) = callbackPtr; \
} while (0)
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 |
callbackPtr->data[1] = (ClientData)(data1); \
callbackPtr->data[2] = (ClientData)(data2); \
callbackPtr->data[3] = (ClientData)(data3); \
callbackPtr->nextPtr = TOP_CB(interp); \
TOP_CB(interp) = callbackPtr; \
} while (0)
#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr))
#else
#define TCLNR_ALLOC(interp, ptr) \
(ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
|
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif /* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ | < > | | > > | | | | < | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # 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 /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. */ |
| ︙ | ︙ | |||
443 444 445 446 447 448 449 | int leaveErrMsg); /* 176 */ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); /* 177 */ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); | | > > | > | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | int leaveErrMsg); /* 176 */ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); /* 177 */ 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, const char *encodingName); /* 179 */ EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ EXTERN struct tm * TclpLocaltime(const time_t *clock); /* 183 */ EXTERN struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ |
| ︙ | ︙ | |||
553 554 555 556 557 558 559 | EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr); /* 234 */ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); | | > | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr); /* 234 */ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ EXTERN int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 239 */ |
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
int *decpt, int *signum, char **endPtr);
/* 250 */
EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
int force);
typedef struct TclIntStubs {
int magic;
| | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
int *decpt, int *signum, char **endPtr);
/* 250 */
EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
int force);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
void (*reserved174)(void);
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
| | | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 |
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
void (*reserved174)(void);
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
void (*reserved184)(void);
void (*reserved185)(void);
void (*reserved186)(void);
|
| ︙ | ︙ | |||
838 839 840 841 842 843 844 |
int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
| | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
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 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
|
| ︙ | ︙ | |||
1160 1161 1162 1163 1164 1165 1166 | /* Slot 174 is reserved */ #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ | > | > | | 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 | /* Slot 174 is reserved */ #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ #define Tcl_SetStartupScript \ (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ #define Tcl_GetStartupScript \ (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #define TclpGmtime \ (tclIntStubsPtr->tclpGmtime) /* 183 */ /* Slot 184 is reserved */ |
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | (tclIntStubsPtr->tclEvalObjEx) /* 232 */ #define TclGetSrcInfoForPc \ (tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */ #define TclVarHashCreateVar \ (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ | > | | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 | (tclIntStubsPtr->tclEvalObjEx) /* 232 */ #define TclGetSrcInfoForPc \ (tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */ #define TclVarHashCreateVar \ (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ #define TclBackgroundException \ (tclIntStubsPtr->tclBackgroundException) /* 236 */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ (tclIntStubsPtr->tclNRInterpProc) /* 238 */ #define TclNRInterpProcCore \ (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */ #define TclNRRunCallbacks \ |
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 1291 1292 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #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 */ #endif #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 98 99 100 101 102 103 104 | /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ EXTERN void TclWinConvertWSAError(DWORD errCode); /* 2 */ | > > > > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ EXTERN void TclWinConvertWSAError(DWORD errCode); /* 2 */ |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | /* 15 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 16 */ EXTERN int TclpIsAtty(int fd); | | > > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | /* 15 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 16 */ EXTERN int TclpIsAtty(int fd); /* 17 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); /* 21 */ |
| ︙ | ︙ | |||
159 160 161 162 163 164 165 166 167 168 169 170 171 172 | EXTERN void TclWinSetInterfaces(int wide); /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); /* 28 */ EXTERN void TclWinResetInterfaces(void); /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 1 */ EXTERN int TclpCloseFile(TclFile file); | > > > > | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | EXTERN void TclWinSetInterfaces(int wide); /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); /* 28 */ EXTERN void TclWinResetInterfaces(void); /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 1 */ EXTERN int TclpCloseFile(TclFile file); |
| ︙ | ︙ | |||
229 230 231 232 233 234 235 236 237 238 239 |
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
| > > > > | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
/* Slot 24 is reserved */
/* Slot 25 is reserved */
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
#endif /* MACOSX */
typedef struct TclIntPlatStubs {
int magic;
void *hooks;
#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 |
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) (DWORD errCode); /* 0 */
void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
int (*tclpIsAtty) (int fd); /* 16 */
| > | > | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned 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 */
void (*tclWinConvertError) (DWORD errCode); /* 0 */
void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
int (*tclpIsAtty) (int fd); /* 16 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
char * (*tclWinNoBackslash) (char *path); /* 24 */
void (*reserved25)(void);
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
int (*tclWinCPUID) (unsigned int index, unsigned 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 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 337 338 339 340 341 342 343 |
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
#endif /* MACOSX */
} TclIntPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern const TclIntPlatStubs *tclIntPlatStubsPtr;
| > | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* MACOSX */
} TclIntPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern const TclIntPlatStubs *tclIntPlatStubsPtr;
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 400 401 402 403 404 405 406 | /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ #define TclWinGetServByName \ | > > | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ #define TclWinGetServByName \ |
| ︙ | ︙ | |||
429 430 431 432 433 434 435 | (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ | | > | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 | (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ #define TclpInetNtoa \ |
| ︙ | ︙ | |||
452 453 454 455 456 457 458 459 460 461 462 463 464 465 | (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ #define TclWinResetInterfaces \ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ | > > | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ #define TclWinResetInterfaces \ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ |
| ︙ | ︙ | |||
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #undef TclpLocaltime_unix #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError | > > | > > > | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 | /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #undef TclpLocaltime_unix #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError #if defined(__WIN32__) || defined(__CYGWIN__) # undef TclWinNToHS # define TclWinNToHS ntohs #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 |
}
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
| | > | | | < | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
}
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
NULL);
return TCL_ERROR;
}
aliasPtr = 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 "
"not my descendant", aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"TARGETSHROUDED", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 |
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
| | > | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 |
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
| | > | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
/*
* The slave interpreter can be deleted while creating the alias.
* [Bug #641195]
*/
| > | | < > | | < | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 |
if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
/*
* The slave interpreter can be deleted while creating the alias.
* [Bug #641195]
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot define or rename alias \"%s\": interpreter deleted",
Tcl_GetCommandName(cmdInterp, cmd)));
return TCL_ERROR;
}
cmdNamePtr = nextAliasPtr->objPtr;
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
TclGetString(cmdNamePtr),
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
/*flags*/ 0);
if (aliasCmd == NULL) {
return TCL_OK;
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot define or rename alias \"%s\": would create a loop",
Tcl_GetCommandName(cmdInterp, cmd)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"ALIASLOOP", NULL);
return TCL_ERROR;
}
/*
* Otherwise, follow the chain one step further. See if the target
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
* the original name (with which it was created) to find the alias to
* delete it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
| | | | 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 |
* the original name (with which it was created) to find the alias to
* delete it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", TclGetString(namePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
TclGetString(namePtr), NULL);
return TCL_ERROR;
}
aliasPtr = Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
return TCL_OK;
|
| ︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 |
/*
* We are sending a 0-refCount obj, do not need a callback: it will be
* cleaned up automatically. But we may need to clear the rootEnsemble
* stuff ...
*/
if (isRootEnsemble) {
| | | | 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
/*
* We are sending a 0-refCount obj, do not need a callback: it will be
* cleaned up automatically. But we may need to clear the rootEnsemble
* stuff ...
*/
if (isRootEnsemble) {
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
static int
AliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
Tcl_GetInterpPath(
Tcl_Interp *askingInterp, /* Interpreter to start search from. */
Tcl_Interp *targetInterp) /* Interpreter to find. */
{
InterpInfo *iiPtr;
if (targetInterp == askingInterp) {
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
| > | > | | | 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 |
Tcl_GetInterpPath(
Tcl_Interp *askingInterp, /* Interpreter to start search from. */
Tcl_Interp *targetInterp) /* Interpreter to find. */
{
InterpInfo *iiPtr;
if (targetInterp == askingInterp) {
Tcl_SetObjResult(askingInterp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){
return TCL_ERROR;
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable,
iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetInterp --
|
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 |
slavePtr = Tcl_GetHashValue(hPtr);
searchInterp = slavePtr->slaveInterp;
if (searchInterp == NULL) {
break;
}
}
if (searchInterp == NULL) {
| | | | 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 |
slavePtr = Tcl_GetHashValue(hPtr);
searchInterp = slavePtr->slaveInterp;
if (searchInterp == NULL) {
break;
}
}
if (searchInterp == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not find interpreter \"%s\"", TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
TclGetString(pathPtr), NULL);
}
return searchInterp;
}
/*
|
| ︙ | ︙ | |||
2252 2253 2254 2255 2256 2257 2258 |
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
int length;
if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
| > | < | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 |
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
int length;
if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cmdPrefix must be list of length >= 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BGERRORFORMAT", NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(slaveInterp, objv[0]);
}
Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp));
|
| ︙ | ︙ | |||
2322 2323 2324 2325 2326 2327 2328 |
safe = Tcl_IsSafe(masterInterp);
}
masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path,
&isNew);
if (isNew == 0) {
| | | > | 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 |
safe = Tcl_IsSafe(masterInterp);
}
masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path,
&isNew);
if (isNew == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"interpreter named \"%s\" already exists, cannot create",
path));
return NULL;
}
slaveInterp = Tcl_CreateInterp();
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
|
| ︙ | ︙ | |||
2856 2857 2858 2859 2860 2861 2862 |
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
int limit;
if (objc) {
if (Tcl_IsSafe(interp)) {
| | | | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 |
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
int limit;
if (objc) {
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
"safe interpreters cannot change recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
}
if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3316 3317 3318 3319 3320 3321 3322 |
(iPtr->limit.cmdCount < iPtr->cmdCount)) {
iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS;
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
| | | | 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 |
(iPtr->limit.cmdCount < iPtr->cmdCount)) {
iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS;
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command count limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Release(interp);
}
|
| ︙ | ︙ | |||
3342 3343 3344 3345 3346 3347 3348 |
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.timeHandlers, interp);
if (iPtr->limit.time.sec > now.sec ||
(iPtr->limit.time.sec == now.sec &&
iPtr->limit.time.usec >= now.usec)) {
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
| | | | 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 |
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.timeHandlers, interp);
if (iPtr->limit.time.sec > now.sec ||
(iPtr->limit.time.sec == now.sec &&
iPtr->limit.time.usec >= now.usec)) {
iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"time limit exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
Tcl_Release(interp);
}
}
|
| ︙ | ︙ | |||
4349 4350 4351 4352 4353 4354 4355 |
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == slaveInterp) {
| | | > | 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 |
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == slaveInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
|
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 |
break;
case OPT_GRAN:
granObj = objv[i+1];
if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
| | | > | < | 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 |
break;
case OPT_GRAN:
granObj = objv[i+1];
if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
case OPT_VAL:
limitObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
if (limitLen == 0) {
break;
}
if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command limit value must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
}
}
|
| ︙ | ︙ | |||
4536 4537 4538 4539 4540 4541 4542 |
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == slaveInterp) {
| | | > | 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 |
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == slaveInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
|
| ︙ | ︙ | |||
4654 4655 4656 4657 4658 4659 4660 |
break;
case OPT_GRAN:
granObj = objv[i+1];
if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
| | | > | < | > | < > | | > | | | 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 |
break;
case OPT_GRAN:
granObj = objv[i+1];
if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
return TCL_ERROR;
}
if (gran < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
case OPT_MILLI:
milliObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"milliseconds must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
limitMoment.usec = ((long) tmp)*1000;
break;
case OPT_SEC:
secObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"seconds must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", NULL);
return TCL_ERROR;
}
limitMoment.sec = tmp;
break;
}
}
if (milliObj != NULL || secObj != NULL) {
if (milliObj != NULL) {
/*
* Setting -milliseconds but clearing -seconds, or resetting
* -milliseconds but not resetting -seconds? Bad voodoo!
*/
if (secObj != NULL && secLen == 0 && milliLen > 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may only set -milliseconds if -seconds is not "
"also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may only reset -milliseconds if -seconds is "
"also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADUSAGE", NULL);
return TCL_ERROR;
}
}
if (milliLen > 0 || secLen > 0) {
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
*/
count = numElems - first;
}
isShared = (listRepPtr->refCount > 1);
numRequired = numElems - count + objc;
if ((numRequired <= listRepPtr->maxElemCount) && !isShared) {
int shift;
/*
* Can use the current List struct. First "delete" count elements
* starting at first.
| > > > > | 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 |
*/
count = numElems - first;
}
isShared = (listRepPtr->refCount > 1);
numRequired = numElems - count + objc;
for (i = 0; i < objc; i++) {
Tcl_IncrRefCount(objv[i]);
}
if ((numRequired <= listRepPtr->maxElemCount) && !isShared) {
int shift;
/*
* Can use the current List struct. First "delete" count elements
* starting at first.
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
+ TCL_MIN_ELEMENT_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
if (listRepPtr == NULL) {
listRepPtr = AttemptNewList(interp, numRequired, NULL);
if (listRepPtr == NULL) {
return TCL_ERROR;
}
}
}
listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
listRepPtr->refCount++;
| > > > > > > > > | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
+ TCL_MIN_ELEMENT_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
if (listRepPtr == NULL) {
listRepPtr = AttemptNewList(interp, numRequired, NULL);
if (listRepPtr == NULL) {
for (i = 0; i < objc; i++) {
/* See bug 3598580 */
#if TCL_MAJOR_VERSION > 8
Tcl_DecrRefCount(objv[i]);
#else
objv[i]->refCount--;
#endif
}
return TCL_ERROR;
}
}
}
listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
listRepPtr->refCount++;
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
}
ckfree(oldListRepPtr);
}
}
/*
| | < < < | 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
}
ckfree(oldListRepPtr);
}
}
/*
* Insert the new elements into elemPtrs before "first".
*/
for (i=0,j=first ; i<objc ; i++,j++) {
elemPtrs[j] = objv[i];
}
/*
* Update the count of elements.
*/
listRepPtr->elemCount = numRequired;
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
| ︙ | ︙ | |||
128 129 130 131 132 133 134 135 136 |
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
Tcl_PackageInitProc *initProc;
const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch;
unsigned len;
if ((objc < 2) || (objc > 4)) {
| > > > > > > > > > > > > > > > > > > > > > > > > > | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
Tcl_PackageInitProc *initProc;
const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch;
unsigned len;
int index, flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
enum options {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
};
while (objc > 2) {
if (TclGetString(objv[1])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
++objv; --objc;
if (LOAD_GLOBAL == (enum options) index) {
flags |= TCL_LOAD_GLOBAL;
} else if (LOAD_LAZY == (enum options) index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
}
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = Tcl_GetString(objv[1]);
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
if (objc >= 3) {
packageName = Tcl_GetString(objv[2]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
| | | < | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
if (objc >= 3) {
packageName = Tcl_GetString(objv[2]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
Tcl_MutexLock(&packageMutex);
defaultPtr = NULL;
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
if (packageName == NULL) {
namesMatch = 0;
} else {
| | | | | | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
Tcl_MutexLock(&packageMutex);
defaultPtr = NULL;
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
if (packageName == NULL) {
namesMatch = 0;
} else {
TclDStringClear(&pkgName);
Tcl_DStringAppend(&pkgName, packageName, -1);
TclDStringClear(&tmp);
Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
Tcl_DStringValue(&pkgName)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
TclDStringClear(&pkgName);
filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
if (filesMatch && (namesMatch || (packageName == NULL))) {
break;
}
if (namesMatch && (fullFileName[0] == 0)) {
defaultPtr = pkgPtr;
}
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
/*
* Can't have two different packages loaded from the same file.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" is already loaded for package \"%s\"",
fullFileName, pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"SPLITPERSONALITY", NULL);
code = TCL_ERROR;
Tcl_MutexUnlock(&packageMutex);
goto done;
}
}
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
if (pkgPtr == NULL) {
/*
* The desired file isn't currently loaded, so load it. It's an error
* if the desired package is a static one.
*/
if (fullFileName[0] == 0) {
| | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
if (pkgPtr == NULL) {
/*
* The desired file isn't currently loaded, so load it. It's an error
* if the desired package is a static one.
*/
if (fullFileName[0] == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package \"%s\" isn't loaded statically", packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
NULL);
code = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
|| !(isalpha(UCHAR(ch)) /* INTL: ISO only */
|| (UCHAR(ch) == '_'))) {
break;
}
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
| | | | | | | | | | | | | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
|| !(isalpha(UCHAR(ch)) /* INTL: ISO only */
|| (UCHAR(ch) == '_'))) {
break;
}
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't figure out package name for %s",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"WHATPACKAGE", NULL);
code = TCL_ERROR;
goto done;
}
Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess);
Tcl_DecrRefCount(splitPtr);
}
}
/*
* Fix the capitalization in the package name so that the first
* character is in caps (or title case) but the others are all
* lower-case.
*/
Tcl_DStringSetLength(&pkgName,
Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
/*
* Compute the names of the two initialization functions, based on the
* package name.
*/
TclDStringAppendDString(&initName, &pkgName);
TclDStringAppendLiteral(&initName, "_Init");
TclDStringAppendDString(&safeInitName, &pkgName);
TclDStringAppendLiteral(&safeInitName, "_SafeInit");
TclDStringAppendDString(&unloadName, &pkgName);
TclDStringAppendLiteral(&unloadName, "_Unload");
TclDStringAppendDString(&safeUnloadName, &pkgName);
TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload");
/*
* Call platform-specific code to load the package and find the two
* initialization functions.
*/
symbols[0] = Tcl_DStringValue(&initName);
symbols[1] = NULL;
Tcl_MutexLock(&packageMutex);
code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc,
&loadHandle);
Tcl_MutexUnlock(&packageMutex);
if (code != TCL_OK) {
goto done;
}
/*
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 | pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); | | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeUnloadName)); pkgPtr->interpRefCount = 0; pkgPtr->safeInterpRefCount = 0; Tcl_MutexLock(&packageMutex); pkgPtr->nextPtr = firstPackagePtr; |
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
/*
* Invoke the package's initialization function (either the normal one or
* the safe one, depending on whether or not the interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeInitProc == NULL) {
| | | | | | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
/*
* Invoke the package's initialization function (either the normal one or
* the safe one, depending on whether or not the interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeInitProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't use package in a safe interpreter: no"
" %s_SafeInit procedure", pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
NULL);
code = TCL_ERROR;
goto done;
}
code = pkgPtr->safeInitProc(target);
} else {
if (pkgPtr->initProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't attach package to interpreter: no %s_Init procedure",
pkgPtr->packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
NULL);
code = TCL_ERROR;
goto done;
}
code = pkgPtr->initProc(target);
}
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
if (objc - i >= 2) {
packageName = Tcl_GetString(objv[i+1]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
| | | < | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
if (objc - i >= 2) {
packageName = Tcl_GetString(objv[i+1]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
defaultPtr = NULL;
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
int namesMatch, filesMatch;
if (packageName == NULL) {
namesMatch = 0;
} else {
| | | | | | > | | | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
defaultPtr = NULL;
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
int namesMatch, filesMatch;
if (packageName == NULL) {
namesMatch = 0;
} else {
TclDStringClear(&pkgName);
Tcl_DStringAppend(&pkgName, packageName, -1);
TclDStringClear(&tmp);
Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
Tcl_DStringValue(&pkgName)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
TclDStringClear(&pkgName);
filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
if (filesMatch && (namesMatch || (packageName == NULL))) {
break;
}
if (namesMatch && (fullFileName[0] == 0)) {
defaultPtr = pkgPtr;
}
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
break;
}
}
Tcl_MutexUnlock(&packageMutex);
if (fullFileName[0] == 0) {
/*
* It's an error to try unload a static package.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package \"%s\" is loaded statically and cannot be unloaded",
packageName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
NULL);
code = TCL_ERROR;
goto done;
}
if (pkgPtr == NULL) {
/*
* The DLL pointed by the provided filename has never been loaded.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" has never been loaded", fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
NULL);
code = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 |
}
}
if (code != TCL_OK) {
/*
* The package has not been loaded in this interpreter.
*/
| | | > | | > | | > | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
}
}
if (code != TCL_OK) {
/*
* The package has not been loaded in this interpreter.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" has never been loaded in this interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
NULL);
code = TCL_ERROR;
goto done;
}
/*
* Ensure that the DLL can be unloaded. If it is a trusted interpreter,
* pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If
* the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL.
*/
if (Tcl_IsSafe(target)) {
if (pkgPtr->safeUnloadProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" cannot be unloaded under a safe interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
NULL);
code = TCL_ERROR;
goto done;
}
unloadProc = pkgPtr->safeUnloadProc;
} else {
if (pkgPtr->unloadProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" cannot be unloaded under a trusted interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
NULL);
code = TCL_ERROR;
goto done;
}
unloadProc = pkgPtr->unloadProc;
}
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 |
ckfree(ipPtr);
Tcl_MutexUnlock(&packageMutex);
} else {
code = TCL_ERROR;
}
}
#else
| | | > | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 |
ckfree(ipPtr);
Tcl_MutexUnlock(&packageMutex);
} else {
code = TCL_ERROR;
}
}
#else
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" cannot be unloaded: unloading disabled",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
NULL);
code = TCL_ERROR;
#endif
}
done:
|
| ︙ | ︙ |
Changes to generic/tclLoadNone.c.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"dynamic loading is not currently available on this system",
-1));
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | | | | | > | | | | < > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * On Windows, this file needs to be compiled twice, once with TCL_ASCII_MAIN * defined. This way both Tcl_Main and Tcl_MainExW can be implemented, sharing * the same source code. */ #if defined(TCL_ASCII_MAIN) # ifdef UNICODE # undef UNICODE # undef _UNICODE # else # define UNICODE # define _UNICODE # endif #endif #include "tclInt.h" /* * The default prompt used when the user has not overridden it. */ #define DEFAULT_PRIMARY_PROMPT "% " /* * This file can be compiled on Windows in UNICODE mode, as well as on all * other platforms using the native encoding. This is done by using the normal * Windows functions like _tcscmp, but on platforms which don't have <tchar.h> * we have to translate that to strcmp here. */ #ifndef __WIN32__ # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp #endif /* |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | /* * Forward declarations for functions defined later in this file. */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); | | > | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | /* * Forward declarations for functions defined later in this file. */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); static void FreeMainInterp(ClientData clientData); #ifndef TCL_ASCII_MAIN static Tcl_ThreadDataKey dataKey; /* *---------------------------------------------------------------------- * * Tcl_SetStartupScript -- * * Sets the path and encoding of the startup script to be evaluated by * Tcl_Main, used to override the command line processing. |
| ︙ | ︙ | |||
328 329 330 331 332 333 334 |
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
| | | | > | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
|
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
| > | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 461 462 463 464 465 466 467 |
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
| > | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); | | > | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 |
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
| | > < > | | < | < | | | | | | | | | | | | > | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
Tcl_CreateChannelHandler(is.input, TCL_READABLE,
StdinProc, &is);
}
mainLoopProc();
Tcl_SetMainLoop(NULL);
if (is.input) {
Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
Tcl_SetMainLoop(NULL);
}
if (is.commandPtr != NULL) {
Tcl_DecrRefCount(is.commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
* happening. Maybe interp has been deleted; maybe [exit] was redefined,
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
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_FindExecutable(argv[0]);
Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
#ifndef TCL_ASCII_MAIN
/*
*---------------------------------------------------------------
*
* Tcl_SetMainLoop --
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
* hunting etc).
*
* Results:
* A boolean.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE int
TclFullFinalizationRequested(void)
{
#ifdef PURIFY
return 1;
#else
const char *fin;
Tcl_DString ds;
int finalize = 0;
fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
finalize = ((fin != NULL) && strcmp(fin, "0"));
if (fin != NULL) {
Tcl_DStringFree(&ds);
}
return finalize;
| > | | 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
* hunting etc).
*
* Results:
* A boolean.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE int
TclFullFinalizationRequested(void)
{
#ifdef PURIFY
return 1;
#else
const char *fin;
Tcl_DString ds;
int finalize = 0;
fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
finalize = ((fin != NULL) && strcmp(fin, "0"));
if (fin != NULL) {
Tcl_DStringFree(&ds);
}
return finalize;
#endif /* PURIFY */
}
#endif /* !TCL_ASCII_MAIN */
/*
*----------------------------------------------------------------------
*
* StdinProc --
|
| ︙ | ︙ | |||
862 863 864 865 866 867 868 |
*
*----------------------------------------------------------------------
*/
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
| | | < | | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
*
*----------------------------------------------------------------------
*/
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE
* after a prompt is printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel chan;
if (isPtr->prompt == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
(isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
return;
}
if (promptCmdPtr == NULL) {
defaultPrompt:
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 | } /* *---------------------------------------------------------------------- * * FreeMainInterp -- * | | | | | | | | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
}
/*
*----------------------------------------------------------------------
*
* FreeMainInterp --
*
* Exit handler used to cleanup the main interpreter and ancillary
* startup script storage at exit.
*
*----------------------------------------------------------------------
*/
static void
FreeMainInterp(
ClientData clientData)
{
Tcl_Interp *interp = clientData;
/*if (TclInExit()) return;*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
Tcl_SetStartupScript(NULL, NULL);
Tcl_Release(interp);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
* mmclennan@lucent.com
*
* 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 "tclCompile.h" /* for TclLogCommandInfo visibility */
/*
* Thread-local storage used to avoid having a global lock on data that is not
* limited to a single interpreter.
*/
typedef struct ThreadSpecificData {
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | 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, | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | 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 void NamespaceFree(Namespace *nsPtr); |
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
| | | | | | | | | | | | | | | | | | | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
{"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
{"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0},
{"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
{"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
{"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
{"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
{"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
{"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0},
{"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
{"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceSubsystem --
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
if ((nsPtr->flags & NS_DYING)
&& (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
| | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 |
if ((nsPtr->flags & NS_DYING)
&& (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclPushStackFrame --
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
* Treat this namespace as the global namespace, and avoid looking for
* a parent.
*/
parentPtr = NULL;
simpleName = "";
} else if (*name == '\0') {
| < | | | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 |
* Treat this namespace as the global namespace, and avoid looking for
* a parent.
*/
parentPtr = NULL;
simpleName = "";
} else if (*name == '\0') {
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
" \"\": only global namespace can have empty name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEGLOBAL", NULL);
return NULL;
} else {
/*
* Find the parent for the new namespace.
*/
TclGetNamespaceForQualName(interp, name, NULL,
|
| ︙ | ︙ | |||
721 722 723 724 725 726 727 |
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
#else
parentPtr->childTablePtr != NULL &&
Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
) {
| | | | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 |
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
#else
parentPtr->childTablePtr != NULL &&
Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create namespace \"%s\": already exists", name));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEEXISTING", NULL);
return NULL;
}
}
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
namePtr = &buffer1;
buffPtr = &buffer2;
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
register Tcl_DString *tempPtr = namePtr;
| | | < | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 |
namePtr = &buffer1;
buffPtr = &buffer2;
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
register Tcl_DString *tempPtr = namePtr;
TclDStringAppendLiteral(buffPtr, "::");
Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
TclDStringAppendDString(buffPtr, namePtr);
/*
* Clear the unwanted buffer or we end up appending to previous
* results, making the namespace fullNames of nested namespaces
* very wrong (and strange).
*/
TclDStringClear(namePtr);
/*
* Now swap the buffer pointers so that we build in the other
* buffer. This is faster than repeated copying back and forth
* between buffers.
*/
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 |
* NOTE: we could avoid traversing the ns's command list by keeping a
* separate list of coros.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
cmdPtr = Tcl_GetHashValue(entryPtr);
| | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
* NOTE: we could avoid traversing the ns's command list by keeping a
* separate list of coros.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
cmdPtr = Tcl_GetHashValue(entryPtr);
if (cmdPtr->nreProc == TclNRInterpCoroutine) {
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
} else {
entryPtr = Tcl_NextHashEntry(&search);
}
}
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 |
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
| | | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 |
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
" \"%s\": pattern can't specify a namespace", pattern));
Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
return TCL_ERROR;
}
/*
* Make sure that we don't already have the pattern in the array
*/
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
/*
* From the pattern, find the namespace from which we are importing and
* get the simple pattern (no namespace qualifiers or ::'s) at the end.
*/
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
| | > | < | | | | | | | | | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 |
/*
* From the pattern, find the namespace from which we are importing and
* get the simple pattern (no namespace qualifiers or ::'s) at the end.
*/
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in import pattern \"%s\"", pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
if (pattern == simplePattern) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no namespace specified in import pattern \"%s\"",
pattern));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" tries to import from namespace"
" \"%s\" into itself", pattern, importNsPtr->name));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
}
return TCL_ERROR;
}
/*
* Scan through the command table in the source namespace and look for
* exported commands that match the string pattern. Create an "imported
|
| ︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 |
ImportedCmdData *dataPtr;
Command *cmdPtr;
ImportRef *refPtr;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
if (nsPtr != ((Interp *) interp)->globalNsPtr) {
| | > | | | | | 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 |
ImportedCmdData *dataPtr;
Command *cmdPtr;
ImportRef *refPtr;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
if (nsPtr != ((Interp *) interp)->globalNsPtr) {
TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, cmdName, -1);
/*
* Check whether creating the new imported command in the current
* namespace would create a cycle of imported command references.
*/
cmdPtr = Tcl_GetHashValue(hPtr);
if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
Command *overwrite = Tcl_GetHashValue(found);
Command *linkCmd = cmdPtr;
while (linkCmd->deleteProc == DeleteImportedCmd) {
dataPtr = linkCmd->objClientData;
linkCmd = dataPtr->realCmdPtr;
if (overwrite == linkCmd) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" would create a loop"
" containing command \"%s\"",
pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
}
}
}
dataPtr = ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 | /* * Repeated import of same command is acceptable. */ return TCL_OK; } } | | | | | 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 |
/*
* Repeated import of same command is acceptable.
*/
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't import command \"%s\": already exists", cmdName));
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1793 1794 1795 1796 1797 1798 1799 |
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
| | | | | 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 |
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in namespace forget pattern \"%s\"",
pattern));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
return TCL_ERROR;
}
if (strcmp(pattern, simplePattern) == 0) {
/*
* The pattern is simple. Delete any imported commands that match it.
|
| ︙ | ︙ | |||
1942 1943 1944 1945 1946 1947 1948 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
| | | 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}
static int
InvokeImportedCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
|
| ︙ | ︙ | |||
2237 2238 2239 2240 2241 2242 2243 | * start points to the beginning of a namespace qualifier ending * in "::". end points to the start of a name in that namespace * that might be empty. Copy the namespace qualifier to a buffer * so it can be null terminated. We can't modify the incoming * qualName since it may be a string constant. */ | | | 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 | * start points to the beginning of a namespace qualifier ending * in "::". end points to the start of a name in that namespace * that might be empty. Copy the namespace qualifier to a buffer * so it can be null terminated. We can't modify the incoming * qualName since it may be a string constant. */ TclDStringClear(&buffer); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } /* * Look up the namespace qualifier nsName in the current namespace * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set, |
| ︙ | ︙ | |||
2399 2400 2401 2402 2403 2404 2405 |
flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
| | | | 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 |
flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2586 2587 2588 2589 2590 2591 2592 |
}
if (cmdPtr != NULL) {
return (Tcl_Command) cmdPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
| | | | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 |
}
if (cmdPtr != NULL) {
return (Tcl_Command) cmdPtr;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown command \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 |
const char *name = TclGetString(objv[2]);
if ((*name == ':') && (*(name+1) == ':')) {
pattern = name;
} else {
Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
if (nsPtr != globalNsPtr) {
| | | 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 |
const char *name = TclGetString(objv[2]);
if ((*name == ':') && (*(name+1) == ':')) {
pattern = name;
} else {
Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
if (nsPtr != globalNsPtr) {
TclDStringAppendLiteral(&buffer, "::");
}
Tcl_DStringAppend(&buffer, name, -1);
pattern = Tcl_DStringValue(&buffer);
}
}
/*
|
| ︙ | ︙ | |||
3167 3168 3169 3170 3171 3172 3173 |
*/
for (i = 1; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
|| (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
| > | | < | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 |
*/
for (i = 1; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
|| (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\" in namespace delete command",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
TclGetString(objv[i]), NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
3282 3283 3284 3285 3286 3287 3288 |
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
| | | | | | | 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 |
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
framePtr->objc = objc;
framePtr->objv = objv;
} else {
framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
if (objc == 3) {
/*
* TIP #280: Make actual argument location available to eval'd script.
*/
|
| ︙ | ︙ | |||
3745 3746 3747 3748 3749 3750 3751 |
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
| | | | | | | 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 |
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
framePtr->objc = objc;
framePtr->objv = objv;
} else {
framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- iPtr->ensembleRewrite.numInsertedObjs;
framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
/*
* Execute the command. If there is just one argument, just treat it as a
* script and evaluate it. Otherwise, create a list from the arguments
* after the first one, then concatenate the first argument and the list
* of extra arguments to form the command to evaluate.
|
| ︙ | ︙ | |||
3831 3832 3833 3834 3835 3836 3837 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
command = Tcl_GetCommandFromObj(interp, objv[1]);
if (command == NULL) {
| | | | 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
command = Tcl_GetCommandFromObj(interp, objv[1]);
if (command == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
origCommand = TclGetOriginalCommand(command);
TclNewObj(resultPtr);
if (origCommand == NULL) {
|
| ︙ | ︙ | |||
3955 3956 3957 3958 3959 3960 3961 |
}
/*
* If no path is given, return the current path.
*/
if (objc == 1) {
| | | | | | 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 |
}
/*
* If no path is given, return the current path.
*/
if (objc == 1) {
Tcl_Obj *resultObj = Tcl_NewObj();
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
if (nsPtr->commandPathArray[i].nsPtr != NULL) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
nsPtr->commandPathArray[i].nsPtr->fullName, -1));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
* There is a path given, so parse it into an array of namespace pointers.
*/
|
| ︙ | ︙ | |||
4840 4841 4842 4843 4844 4845 4846 |
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
int length, /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
const unsigned char *pc, /* Current pc of bytecode execution context */
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 |
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
int length, /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
const unsigned char *pc, /* Current pc of bytecode execution context */
Tcl_Obj **tosPtr) /* Current stack of bytecode execution
* context */
{
register const char *p;
Interp *iPtr = (Interp *) interp;
int overflow, limit = 150;
Var *varPtr, *arrayPtr;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
* Someone else has already logged error information for this command;
* we shouldn't add anything more.
*/
return;
}
if (command != NULL) {
/*
* Compute the line number where the error occurred.
*/
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
if (length < 0) {
length = strlen(command);
}
overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
? "while executing" : "invoked from within"),
(overflow ? limit : length), command,
(overflow ? "..." : "")));
varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
NULL, 0, 0, &arrayPtr);
if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
/*
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
if (tracePtr->traceProc != EstablishErrorInfoTraces) {
/*
* The most recent trace set on ::errorInfo is not the one the
* core itself puts on last. This means some other code is
* tracing the variable, and the additional trace(s) might be
* write traces that expect the timing of writes to
* ::errorInfo that existed Tcl releases before 8.5. To
* satisfy that compatibility need, we write the current
* -errorinfo value to the ::errorInfo variable.
*/
Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
TCL_GLOBAL_ONLY);
}
}
}
/*
* TIP #348
*/
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
int len;
iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list intrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
if (pc != NULL) {
Tcl_Obj *innerContext;
innerContext = TclGetInnerContext(interp, pc, tosPtr);
if (innerContext != NULL) {
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
iPtr->innerLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
}
} else if (command != NULL) {
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
iPtr->innerLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
Tcl_NewStringObj(command, length));
}
}
if (!iPtr->framePtr->objc) {
/*
* Special frame, nothing to report.
*/
} else if (iPtr->varFramePtr != iPtr->framePtr) {
/*
* uplevel case, [lappend errorstack UP $relativelevel]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
iPtr->framePtr->level - iPtr->varFramePtr->level));
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
/*
* normal case, [lappend errorstack CALL [info level 0]]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
iPtr->framePtr->objc, iPtr->framePtr->objv));
}
}
/*
*----------------------------------------------------------------------
*
* TclErrorStackResetIf --
*
* The TIP 348 reset/no-bc part of TLCI, for specific use by
* TclCompileSyntaxError.
*
* Results:
* None.
*
* Side effects:
* Reset errorstack if it needs be, and in that case remember the
* passed-in error message as inner context.
*
*----------------------------------------------------------------------
*/
void
TclErrorStackResetIf(
Tcl_Interp *interp,
const char *msg,
int length)
{
Interp *iPtr = (Interp *) interp;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
int len;
iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list intrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
Tcl_NewStringObj(msg, length));
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_LogCommandInfo --
|
| ︙ | ︙ | |||
5062 5063 5064 5065 5066 5067 5068 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 | < | 5061 5062 5063 5064 5065 5066 5067 5068 5069 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * End: */ |
Changes to generic/tclOO.c.
1 2 3 4 5 | /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 84 85 86 87 88 89 90 | Tcl_Interp *interp); static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, | > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | Tcl_Interp *interp); static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, |
| ︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = ckalloc(sizeof(Foundation));
Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
Tcl_DString buffer;
int i;
/*
* Initialize the structure that holds the OO system core. This is
* attached to the interpreter via an assocData entry; not very efficient,
* but the best we can do without hacking the core more.
*/
| > | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = ckalloc(sizeof(Foundation));
Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
/*
* Initialize the structure that holds the OO system core. This is
* attached to the interpreter via an assocData entry; not very efficient,
* but the best we can do without hacking the core more.
*/
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
Tcl_DStringInit(&buffer);
for (i=0 ; defineCmds[i].name ; i++) {
| | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
/*
* Create the subcommands in the oo::define and oo::objdefine spaces.
*/
Tcl_DStringInit(&buffer);
for (i=0 ; defineCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::define::");
Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
for (i=0 ; objdefCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 |
* ensemble.
*/
Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
NULL, NULL);
| | | > | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
* ensemble.
*/
Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
NULL, NULL);
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);
|
| ︙ | ︙ | |||
653 654 655 656 657 658 659 |
PublicObjectCmd, oPtr, NULL);
} else {
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer,
Tcl_GetCurrentNamespace(interp)->fullName, -1);
| | | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 |
PublicObjectCmd, oPtr, NULL);
} else {
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer,
Tcl_GetCurrentNamespace(interp)->fullName, -1);
TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, nameStr, -1);
oPtr->command = Tcl_CreateObjCommand(interp,
Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
Tcl_DStringFree(&buffer);
}
/*
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
cmdPtr->clientData = cmdPtr;
cmdPtr->nreProc = PrivateNRObjectCmd;
Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
oPtr->myCommand = (Tcl_Command) cmdPtr;
return oPtr;
}
/*
* ----------------------------------------------------------------------
*
* MyDeleted --
*
* This callback is triggered when the object's [my] command is deleted
| > > > > > > > > > > > > > > > > > > > > > | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 |
cmdPtr->clientData = cmdPtr;
cmdPtr->nreProc = PrivateNRObjectCmd;
Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
oPtr->myCommand = (Tcl_Command) cmdPtr;
return oPtr;
}
/*
* ----------------------------------------------------------------------
*
* SquelchCachedName --
*
* Encapsulates how to throw away a cached object name. Called from
* object rename traces and at object destruction.
*
* ----------------------------------------------------------------------
*/
static inline void
SquelchCachedName(
Object *oPtr)
{
if (oPtr->cachedNameObj) {
Tcl_DecrRefCount(oPtr->cachedNameObj);
oPtr->cachedNameObj = NULL;
}
}
/*
* ----------------------------------------------------------------------
*
* MyDeleted --
*
* This callback is triggered when the object's [my] command is deleted
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 |
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
*/
if (flags & TCL_TRACE_RENAME) {
| | < < < | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 |
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
*/
if (flags & TCL_TRACE_RENAME) {
SquelchCachedName(oPtr);
return;
}
/*
* Oh dear, the object really is being deleted. Handle this by running the
* destructors and deleting the object's namespace, which in turn causes
* the real object structures to be deleted.
|
| ︙ | ︙ | |||
1134 1135 1136 1137 1138 1139 1140 |
ckfree(oPtr->variables.list);
}
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
| | < < < | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
ckfree(oPtr->variables.list);
}
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
SquelchCachedName(oPtr);
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
|
| ︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 |
/*
* Check if we're going to create an object over an existing command;
* that's not allowed.
*/
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
| | | > | 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 |
/*
* Check if we're going to create an object over an existing command;
* that's not allowed.
*/
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
/*
* Create the object.
*/
|
| ︙ | ︙ | |||
1629 1630 1631 1632 1633 1634 1635 |
/*
* It's an error if the object was whacked in the constructor.
* Force this if it isn't already an error (don't want to lose
* errors by accident...) [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
| > | < | 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 |
/*
* It's an error if the object was whacked in the constructor.
* Force this if it isn't already an error (don't want to lose
* errors by accident...) [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
TclOODeleteContext(contextPtr);
if (result != TCL_OK) {
Tcl_DiscardInterpState(state);
|
| ︙ | ︙ | |||
1685 1686 1687 1688 1689 1690 1691 |
/*
* Check if we're going to create an object over an existing command;
* that's not allowed.
*/
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
| | | > | 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
/*
* Check if we're going to create an object over an existing command;
* that's not allowed.
*/
if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
TCL_NAMESPACE_ONLY)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return TCL_ERROR;
}
/*
* Create the object.
*/
|
| ︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 |
/*
* It's an error if the object was whacked in the constructor. Force this
* if it isn't already an error (don't want to lose errors by accident...)
* [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
| > | | 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 |
/*
* It's an error if the object was whacked in the constructor. Force this
* if it isn't already an error (don't want to lose errors by accident...)
* [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
TclOODeleteContext(contextPtr);
if (result != TCL_OK) {
Tcl_DiscardInterpState(state);
|
| ︙ | ︙ | |||
1831 1832 1833 1834 1835 1836 1837 |
int i, result;
/*
* Sanity check.
*/
if (IsRootClass(oPtr)) {
| > | | 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 |
int i, result;
/*
* Sanity check.
*/
if (IsRootClass(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not clone the class of classes", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
return NULL;
}
/*
* Build the instance. Note that this does not run any constructors.
*/
|
| ︙ | ︙ | |||
2494 2495 2496 2497 2498 2499 2500 |
*/
Tcl_IncrRefCount(mappedMethodName);
contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
| > | | < > | | < | 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 |
*/
Tcl_IncrRefCount(mappedMethodName);
contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
TclGetString(methodNamePtr), NULL);
return TCL_ERROR;
}
} else {
/*
* Get the call chain.
*/
noMapping:
contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
flags | (oPtr->flags & FILTER_HANDLING), NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
2538 2539 2540 2541 2542 2543 2544 |
continue;
}
if (miPtr->mPtr->declaringClassPtr == startCls) {
break;
}
}
if (contextPtr->index >= contextPtr->callPtr->numChain) {
| > | < | 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 |
continue;
}
if (miPtr->mPtr->declaringClassPtr == startCls) {
break;
}
}
if (contextPtr->index >= contextPtr->callPtr->numChain) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no valid method implementation", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(methodNamePtr), NULL);
TclOODeleteContext(contextPtr);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2620 2621 2622 2623 2624 2625 2626 |
methodType = "constructor";
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
methodType = "destructor";
} else {
methodType = "method";
}
| | | | 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 |
methodType = "constructor";
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
methodType = "destructor";
} else {
methodType = "method";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
return TCL_ERROR;
}
/*
* Advance to the next method implementation in the chain in the method
* call context while we process the body. However, need to adjust the
|
| ︙ | ︙ | |||
2689 2690 2691 2692 2693 2694 2695 |
methodType = "constructor";
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
methodType = "destructor";
} else {
methodType = "method";
}
| | | | 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 |
methodType = "constructor";
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
methodType = "destructor";
} else {
methodType = "method";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
return TCL_ERROR;
}
/*
* Advance to the next method implementation in the chain in the method
* call context while we process the body. However, need to adjust the
|
| ︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 |
if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
goto notAnObject;
}
}
return cmdPtr->objClientData;
notAnObject:
| | | | 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 |
if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
goto notAnObject;
}
}
return cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to an object", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
NULL);
return NULL;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclOO.h.
1 2 3 4 5 6 | /* * tclOO.h -- * * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOO.h -- * * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006-2010 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 | /* * Be careful when it comes to versioning; need to make sure that the * standalone TclOO version matches. Also make sure that this matches the * version in the files: * * tests/oo.test * unix/tclooConfig.sh * win/tclooConfig.sh */ | > | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | /* * Be careful when it comes to versioning; need to make sure that the * standalone TclOO version matches. Also make sure that this matches the * version in the files: * * tests/oo.test * tests/ooNext2.test * unix/tclooConfig.sh * win/tclooConfig.sh */ #define TCLOO_VERSION "1.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* * These are opaque types. */ typedef struct Tcl_Class_ *Tcl_Class; |
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
1 2 3 4 5 6 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
| | | > | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
/*
* Check we have the right number of (sensible) arguments.
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
| | | > | > | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
/*
* Check we have the right number of (sensible) arguments.
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
nsName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"namespace name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 |
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
| | | | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
/*
* Make the object and return its name.
*/
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
/*
* If no method name, generate an error asking for a method name. (Only by
* overriding *this* method can an object handle the absence of a method
* name without an error).
*/
| > | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
Tcl_Obj *errorMsg;
/*
* If no method name, generate an error asking for a method name. (Only by
* overriding *this* method can an object handle the absence of a method
* name without an error).
*/
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 532 |
/*
* Special message when there are no visible methods at all.
*/
if (numMethodNames == 0) {
Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
| > < | | > > > | < | | | | > | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
/*
* Special message when there are no visible methods at all.
*/
if (numMethodNames == 0) {
Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
const char *piece;
if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
piece = "visible methods";
} else {
piece = "methods";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
TclGetString(objv[skip]));
for (i=0 ; i<numMethodNames-1 ; i++) {
if (i) {
Tcl_AppendToObj(errorMsg, ", ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
ckfree(methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
/*
* The variable name must not contain a '::' since that's illegal in
* local names.
*/
if (strstr(varName, "::") != NULL) {
| | | > | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 |
/*
* The variable name must not contain a '::' since that's illegal in
* local names.
*/
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable name \"%s\" illegal: must not contain namespace"
" separator", varName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
/*
* Switch to the object's namespace for the duration of this call.
* Like this, the variable is looked up in the namespace of the
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
/*
* Start with sanity checks on the calling context to make sure that we
* are invoked from a suitable method context. If so, we can safely
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
| | | > | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
/*
* Start with sanity checks on the calling context to make sure that we
* are invoked from a suitable method context. If so, we can safely
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
context = framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
/*
* Start with sanity checks on the calling context to make sure that we
* are invoked from a suitable method context. If so, we can safely
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
| | | > | | > | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 |
/*
* Start with sanity checks on the calling context to make sure that we
* are invoked from a suitable method context. If so, we can safely
* retrieve the handle to the object call context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
contextPtr = framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
return TCL_ERROR;
}
object = Tcl_GetObjectFromObj(interp, objv[1]);
if (object == NULL) {
return TCL_ERROR;
}
classPtr = ((Object *)object)->classPtr;
if (classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
return TCL_ERROR;
}
/*
* Search for an implementation of a method associated with the current
* call on the call chain past the point where we currently are. Do not
* allow jumping backwards!
|
| ︙ | ︙ | |||
877 878 879 880 881 882 883 |
* is on the chain but unreachable, or not on the chain at all.
*/
for (i=contextPtr->index ; i>=0 ; i--) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
| > | | < > | | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
* is on the chain but unreachable, or not on the chain at all.
*/
for (i=contextPtr->index ; i>=0 ; i--) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method implementation by \"%s\" not reachable from here",
TclGetString(objv[1])));
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method has no non-filter implementation by \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
static int
RestoreFrame(
ClientData data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
((contextPtr)->callPtr->chain[(contextPtr)->index])
/*
* Start with sanity checks on the calling context and the method context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
| | | > | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
((contextPtr)->callPtr->chain[(contextPtr)->index])
/*
* Start with sanity checks on the calling context and the method context.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
contextPtr = framePtr->clientData;
/*
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
contextPtr->oPtr->namespacePtr->fullName,-1));
return TCL_OK;
case SELF_CLASS: {
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
| > | > | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
contextPtr->oPtr->namespacePtr->fullName,-1));
return TCL_OK;
case SELF_CLASS: {
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method not defined by a class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
return TCL_OK;
}
case SELF_METHOD:
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
} else {
Tcl_SetObjResult(interp,
CurrentlyInvoked(contextPtr).mPtr->namePtr);
}
return TCL_OK;
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
|
| ︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 |
result[2] = miPtr->mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
return TCL_OK;
}
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
| > | > | | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 |
result[2] = miPtr->mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
return TCL_OK;
}
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
CallContext *callerPtr = framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = TclOOObjectName(interp, callerPtr->oPtr);
if (callerPtr->callPtr->flags & CONSTRUCTOR) {
result[2] = declarerPtr->fPtr->constructorName;
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
| > | > | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 |
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
result[1] = declarerPtr->fPtr->constructorName;
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
result[1] = declarerPtr->fPtr->destructorName;
} else {
result[1] = mPtr->namePtr;
}
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
}
return TCL_OK;
case SELF_TARGET:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
Method *mPtr;
Object *declarerPtr;
int i;
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
| > | | 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 |
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
} else {
/*
* This should be unreachable code.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 |
if (name[0]!=':' || name[1]!=':') {
Interp *iPtr = (Interp *) interp;
if (iPtr->varFramePtr != NULL) {
Tcl_DStringAppend(&buffer,
iPtr->varFramePtr->nsPtr->fullName, -1);
}
| | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 |
if (name[0]!=':' || name[1]!=':') {
Interp *iPtr = (Interp *) interp;
if (iPtr->varFramePtr != NULL) {
Tcl_DStringAppend(&buffer,
iPtr->varFramePtr->nsPtr->fullName, -1);
}
TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, name, -1);
name = Tcl_DStringValue(&buffer);
}
o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
Tcl_DStringFree(&buffer);
}
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
1 2 3 4 5 6 | /* * tclOOCall.c -- * * This file contains the method call chain management code for the * object-system core. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOOCall.c -- * * This file contains the method call chain management code for the * object-system core. * * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ |
Changes to generic/tclOODecls.h.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | /* 27 */ TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); | | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
/* 27 */
TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp,
Tcl_Class clazz, Tcl_Method method);
/* 28 */
TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
Tcl_Object object);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
} TclOOStubHooks;
typedef struct TclOOStubs {
int magic;
const TclOOStubHooks *hooks;
Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 0 */
Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */
Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */
Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */
Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */
Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
1 2 3 4 5 6 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
Tcl_HashEntry *hPtr, *newHPtr = NULL;
Method *mPtr;
int isNew;
if (!useClass) {
if (!oPtr->methodsPtr) {
noSuchMethod:
| | | > | < > | | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
Tcl_HashEntry *hPtr, *newHPtr = NULL;
Method *mPtr;
int isNew;
if (!useClass) {
if (!oPtr->methodsPtr) {
noSuchMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(fromPtr), NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
if (hPtr == NULL) {
goto noSuchMethod;
}
if (toPtr) {
newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr,
&isNew);
if (hPtr == newHPtr) {
renameToSelf:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot rename method to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
return TCL_ERROR;
} else if (!isNew) {
renameToExisting:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method called %s already exists",
TclGetString(toPtr)));
Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
return TCL_ERROR;
}
}
} else {
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
(char *) fromPtr);
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
int soughtLen;
const char *soughtStr, *matchedStr = NULL;
if (objc < 2) {
| > | | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 |
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
int soughtLen;
const char *soughtStr, *matchedStr = NULL;
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad call of unknown handler", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
return TCL_ERROR;
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 |
result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
TclStackFree(interp, newObjv);
return result;
}
noMatch:
| > | | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
TclStackFree(interp, newObjv);
return result;
}
noMatch:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", soughtStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
int objc,
Tcl_Obj *const objv[])
{
CallFrame *framePtr, **framePtrPtr = &framePtr;
int result;
if (namespacePtr == NULL) {
| | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
int objc,
Tcl_Obj *const objv[])
{
CallFrame *framePtr, **framePtrPtr = &framePtr;
int result;
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot process definitions; support namespace deleted",
-1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
/* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 |
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
|| (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
| > | | < > | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
|| (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
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;
if (Tcl_ObjectDeleted(object)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command cannot be called when the object has been"
" deleted", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
return object;
}
/*
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
iPtr->varFramePtr = savedFramePtr;
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
| | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
iPtr->varFramePtr = savedFramePtr;
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(className), NULL);
return NULL;
}
return oPtr->classPtr;
}
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
| | | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to a class",TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
/*
* Make the oo::define namespace the current namespace and evaluate the
|
| ︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 |
*/
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->flags & ROOT_OBJECT) {
| | | | | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
*/
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->flags & ROOT_OBJECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the class of the root object class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
if (oPtr->flags & ROOT_CLASS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the class of the class of classes", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
/*
* Parse the argument to get the class to set the object's class to.
*/
|
| ︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 |
/*
* Apply semantic checks. In particular, classes and non-classes are not
* interchangable (too complicated to do the conversion!) so we must
* produce an error if any attempt is made to swap from one to the other.
*/
if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
| > | | | | 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 |
/*
* Apply semantic checks. In particular, classes and non-classes are not
* interchangable (too complicated to do the conversion!) so we must
* produce an error if any attempt is made to swap from one to the other.
*/
if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"may not change a %sclass object into a %sclass object",
(oPtr->classPtr==NULL ? "non-" : ""),
(oPtr->classPtr==NULL ? "" : "non-")));
Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
return TCL_ERROR;
}
/*
* Set the object's class.
*/
|
| ︙ | ︙ | |||
1313 1314 1315 1316 1317 1318 1319 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
| > | | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
for (i=1 ; i<objc ; i++) {
/*
* Delete the method structure from the appropriate hash table.
|
| ︙ | ︙ | |||
1436 1437 1438 1439 1440 1441 1442 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
| > | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
for (i=1 ; i<objc ; i++) {
/*
* Exporting is done by adding the PUBLIC_METHOD flag to the method
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceForward && !oPtr->classPtr) {
| > | | 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceForward && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
? PUBLIC_METHOD : 0;
/*
|
| ︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceMethod && !oPtr->classPtr) {
| > | | 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
? PUBLIC_METHOD : 0;
/*
|
| ︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 |
Class **mixins;
int i;
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceMixin && !oPtr->classPtr) {
| > | > | | 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 |
Class **mixins;
int i;
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceMixin && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
for (i=1 ; i<objc ; i++) {
Class *clsPtr = GetClassInOuterContext(interp, objv[i],
"may only mix in classes");
if (clsPtr == NULL) {
goto freeAndError;
}
if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
mixins[i-1] = clsPtr;
}
if (isInstanceMixin) {
|
| ︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceRenameMethod && !oPtr->classPtr) {
| > | | 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!isInstanceRenameMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
/*
* Delete the method entry from the appropriate hash table, and transfer
* the thing it points to to its new entry. To do this, we first need to
|
| ︙ | ︙ | |||
1760 1761 1762 1763 1764 1765 1766 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceUnexport && !clsPtr) {
| > | | 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 |
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
for (i=1 ; i<objc ; i++) {
/*
* Unexporting is done by removing the PUBLIC_METHOD flag from the
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | | 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
FOREACH(filterObj, oPtr->classPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | | 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
FOREACH(mixinPtr, oPtr->classPtr->mixins) {
Tcl_ListObjAppendElement(NULL, resultObj,
|
| ︙ | ︙ | |||
2061 2062 2063 2064 2065 2066 2067 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | > | | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i=0 ; i<mixinc ; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not mix a class into itself", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
}
TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
TclStackFree(interp, mixins);
|
| ︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | | 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
FOREACH(superPtr, oPtr->classPtr->superclasses) {
Tcl_ListObjAppendElement(NULL, resultObj,
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | | | | 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the superclass of the root object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
&superv) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2192 2193 2194 2195 2196 2197 2198 |
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
if (superclasses[j] == superclasses[i]) {
| | | | | | 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 |
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
ckfree((char *) superclasses);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2261 2262 2263 2264 2265 2266 2267 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | | 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
}
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
FOREACH(variableObj, oPtr->classPtr->variables) {
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
|
| ︙ | ︙ | |||
2297 2298 2299 2300 2301 2302 2303 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
| > | > | | < > | | | 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 |
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (oPtr == NULL) {
return TCL_ERROR;
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i=0 ; i<varc ; i++) {
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "refer to an array element"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
}
for (i=0 ; i<varc ; i++) {
Tcl_IncrRefCount(varv[i]);
|
| ︙ | ︙ | |||
2587 2588 2589 2590 2591 2592 2593 |
return TCL_ERROR;
}
for (i=0 ; i<varc ; i++) {
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
| > | | < > | | | 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 |
return TCL_ERROR;
}
for (i=0 ; i<varc ; i++) {
const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "refer to an array element"));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
return TCL_ERROR;
}
}
for (i=0 ; i<varc ; i++) {
Tcl_IncrRefCount(varv[i]);
}
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
1 2 3 4 5 6 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo-related [info] * subcommands. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo-related [info] * subcommands. * * Copyright (c) 2006-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMethodTypeCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < > | | < < < < < < < < < < < | < < < < < | < < < < | < < < < < < | | | | < < | < < | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
/*
* List of commands that are used to implement the [info object] subcommands.
*/
static const EnsembleImplMap infoObjectCmds[] = {
{"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
{"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
{"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
{"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* List of commands that are used to implement the [info class] subcommands.
*/
static const EnsembleImplMap infoClassCmds[] = {
{"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* ----------------------------------------------------------------------
*
* TclOOInitInfo --
*
* Adjusts the Tcl core [info] command to contain subcommands ("object"
* and "class") for introspection of objects and classes.
*
* ----------------------------------------------------------------------
*/
void
TclOOInitInfo(
Tcl_Interp *interp)
{
Tcl_Command infoCmd;
Tcl_Obj *mapDict;
/*
* Build the ensembles used to implement [info object] and [info class].
*/
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the master [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
Tcl_NewStringObj("::oo::InfoObject", -1));
Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1),
Tcl_NewStringObj("::oo::InfoClass", -1));
Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
}
/*
* ----------------------------------------------------------------------
*
* GetClassFromObj --
*
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 |
{
Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
| | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
{
Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);
if (oPtr == NULL) {
return NULL;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objPtr), NULL);
return NULL;
}
return oPtr->classPtr;
}
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
| | | | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
resultObjs[0] = Tcl_NewObj();
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
| | | | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, prefixObj);
return TCL_OK;
|
| ︙ | ︙ | |||
487 488 489 490 491 492 493 |
return TCL_ERROR;
}
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
if (o2Ptr == NULL) {
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
| > | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
return TCL_ERROR;
}
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
if (o2Ptr == NULL) {
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"non-classes cannot be mixins", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
} else {
Class *mixinPtr;
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr == o2Ptr->classPtr) {
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
return TCL_ERROR;
}
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
if (o2Ptr == NULL) {
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
| > | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 |
return TCL_ERROR;
}
o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
if (o2Ptr == NULL) {
return TCL_ERROR;
}
if (o2Ptr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"non-classes cannot be types", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
return TCL_ERROR;
}
if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
| | | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 |
if (!oPtr->methodsPtr) {
goto unknownMethod;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
mPtr = Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
|
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
return TCL_ERROR;
}
if (clsPtr->constructorPtr == NULL) {
return TCL_OK;
}
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
if (procPtr == NULL) {
| | | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 |
return TCL_ERROR;
}
if (clsPtr->constructorPtr == NULL) {
return TCL_OK;
}
procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
resultObjs[0] = Tcl_NewObj();
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
| | | | | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 |
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
resultObjs[0] = Tcl_NewObj();
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
|
| ︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 |
}
if (clsPtr->destructorPtr == NULL) {
return TCL_OK;
}
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
if (procPtr == NULL) {
| | | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
}
if (clsPtr->destructorPtr == NULL) {
return TCL_OK;
}
procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 |
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
| | | | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 |
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, prefixObj);
return TCL_OK;
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
| | | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 |
if (clsPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
mPtr = Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 |
/*
* Get the call context and render its call chain.
*/
contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
if (contextPtr == NULL) {
| > | | 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
/*
* Get the call context and render its call chain.
*/
contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp,
TclOORenderCallChain(interp, contextPtr->callPtr));
TclOODeleteContext(contextPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
/*
* Get an render the stereotypical call chain.
*/
callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
if (callPtr == NULL) {
| > | | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
/*
* Get an render the stereotypical call chain.
*/
callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
if (callPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
TclOODeleteChain(callPtr);
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
1 2 3 4 5 6 | /* * tclOOInt.h -- * * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOOInt.h -- * * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef TCL_OO_INTERNAL_H #define TCL_OO_INTERNAL_H 1 |
| ︙ | ︙ |
Changes to generic/tclOOIntDecls.h.
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
/* 15 */
TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp,
Class *classPtr, int numMixins,
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
| | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
/* 15 */
TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp,
Class *classPtr, int numMixins,
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */
Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */
Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */
Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */
int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
1 2 3 4 5 | /* * tclOOMethod.c -- * * This file contains code to create and manage methods. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclOOMethod.c -- * * This file contains code to create and manage methods. * * Copyright (c) 2005-2011 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 |
register ForwardMethod *fmPtr;
Tcl_Obj *cmdObj;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
| > | < | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
register ForwardMethod *fmPtr;
Tcl_Obj *cmdObj;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 |
register ForwardMethod *fmPtr;
Tcl_Obj *cmdObj;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
| > | < | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
register ForwardMethod *fmPtr;
Tcl_Obj *cmdObj;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
|
| ︙ | ︙ |
Changes to generic/tclOOStubLib.c.
1 2 3 4 | /* * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ | < < < < < < < < < < < < < | | > | | < | < < < < < < < < < | | | | < | < < | > > > | > | < | | | | | | | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
/*
* ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17
*/
#include "tclOOInt.h"
MODULE_SCOPE const TclOOStubs *tclOOStubsPtr;
MODULE_SCOPE const TclOOIntStubs *tclOOIntStubsPtr;
const TclOOStubs *tclOOStubsPtr = NULL;
const TclOOIntStubs *tclOOIntStubsPtr = NULL;
/*
*----------------------------------------------------------------------
*
* TclOOInitializeStubs --
* Load the tclOO package, initialize stub table pointer. Do not call
* this function directly, use Tcl_OOInitStubs() macro instead.
*
* Results:
* The actual version of the package that satisfies the request, or NULL
* to indicate that an error occurred.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE const char *
TclOOInitializeStubs(
Tcl_Interp *interp,
const char *version)
{
int exact = 0;
const char *packageName = "TclOO";
const char *errMsg = NULL;
TclOOStubs *stubsPtr = NULL;
const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
} else {
tclOOStubsPtr = stubsPtr;
if (stubsPtr->hooks) {
tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs;
} else {
tclOOIntStubsPtr = NULL;
}
return actualVersion;
}
tclStubsPtr->tcl_ResetResult(interp);
tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
" (requested version ", version, ", actual version ",
actualVersion, "): ", errMsg, NULL);
return NULL;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
4458 4459 4460 4461 4462 4463 4464 |
int
Tcl_RepresentationCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | < < < < | | > | > | | | | | | > < < | | | > | > > | 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 |
int
Tcl_RepresentationCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
/*
* Value is a bignum with a refcount of 14, object pointer at 0x12345678,
* internal representation 0x45671234:0x98765432, string representation
* "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);
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]->bytes) {
Tcl_AppendToObj(descObj, ", string representation \"", -1);
Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length,
16, "...");
Tcl_AppendToObj(descObj, "\"", -1);
} else {
Tcl_AppendToObj(descObj, ", no string representation", -1);
}
Tcl_SetObjResult(interp, descObj);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
|
| ︙ | ︙ |
Changes to generic/tclPanic.c.
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
#endif
} else {
fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7,
arg8);
fprintf(stderr, "\n");
fflush(stderr);
| < < | | | | | | > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
#endif
} else {
fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7,
arg8);
fprintf(stderr, "\n");
fflush(stderr);
#if defined(_WIN32) || defined(__CYGWIN__)
# if defined(__GNUC__)
__builtin_trap();
# elif defined(_WIN64)
__debugbreak();
# elif defined(_MSC_VER)
_asm {int 3}
# else
DebugBreak();
# endif
#endif
#if defined(_WIN32)
ExitProcess(1);
#else
abort();
#endif
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Panic --
*
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | * open bracket. * TYPE_QUOTE - Character is a double quote. * TYPE_CLOSE_PAREN - Character is a right parenthesis. * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). */ | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
* open bracket.
* TYPE_QUOTE - Character is a double quote.
* TYPE_CLOSE_PAREN - Character is a right parenthesis.
* TYPE_CLOSE_BRACK - Character is a right square bracket.
* TYPE_BRACE - Character is a curly brace (either left or right).
*/
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,
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
| > | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(start);
}
TclParseInit(interp, start, numBytes, parsePtr);
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
if ((type & terminators) != 0) {
parsePtr->term = src;
src++;
break;
}
if (src[-1] == '"') {
if (interp != NULL) {
| > | < > | < | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
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;
}
|
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 |
if ((nestedPtr->term < parsePtr->end)
&& (*(nestedPtr->term) == ']')
&& !(nestedPtr->incomplete)) {
break;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
| | | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
if ((nestedPtr->term < parsePtr->end)
&& (*(nestedPtr->term) == ']')
&& !(nestedPtr->incomplete)) {
break;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
"missing close-bracket", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->term = tokenPtr->start;
parsePtr->incomplete = 1;
TclStackFree(parsePtr->interp, nestedPtr);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
while (numBytes && (*src != '}')) {
numBytes--;
src++;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
| | | | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 |
while (numBytes && (*src != '}')) {
numBytes--;
src++;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
"missing close-brace for variable name", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
parsePtr->term = tokenPtr->start-1;
parsePtr->incomplete = 1;
goto error;
}
tokenPtr->size = src - tokenPtr->start;
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
TCL_SUBST_ALL, parsePtr)) {
goto error;
}
if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
if (parsePtr->interp != NULL) {
| | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 |
if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
TCL_SUBST_ALL, parsePtr)) {
goto error;
}
if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
if (parsePtr->interp != NULL) {
Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
"missing )", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
parsePtr->term = src;
parsePtr->incomplete = 1;
goto error;
}
src = parsePtr->term + 1;
|
| ︙ | ︙ | |||
1751 1752 1753 1754 1755 1756 1757 |
* Skip straight to the exit code since we have no interpreter to put
* error message in.
*/
goto error;
}
| > | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 |
* Skip straight to the exit code since we have no interpreter to put
* error message in.
*/
goto error;
}
Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
"missing close-brace", -1));
/*
* Guess if the problem is due to comments by searching the source string
* for a possible open brace within the context of a comment. Since we
* aren't performing a full Tcl parse, just look for an open brace
* preceded by a '<whitespace>#' on the same line.
*/
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && TclIsSpaceProc(src[-1])) {
| | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 |
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && TclIsSpaceProc(src[-1])) {
Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
": possible unbalanced brace in comment", -1);
goto error;
}
break;
}
}
}
|
| ︙ | ︙ | |||
1853 1854 1855 1856 1857 1858 1859 |
if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
if (parsePtr->interp != NULL) {
| | > | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
if (parsePtr->interp != NULL) {
Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
"missing \"", -1));
}
parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
parsePtr->term = start;
parsePtr->incomplete = 1;
goto error;
}
if (termPtr != NULL) {
|
| ︙ | ︙ |
Changes to generic/tclParse.h.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | #define TYPE_COMMAND_END 0x2 #define TYPE_SUBS 0x4 #define TYPE_QUOTE 0x8 #define TYPE_CLOSE_PAREN 0x10 #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 | | | | 8 9 10 11 12 13 14 15 16 17 | #define TYPE_COMMAND_END 0x2 #define TYPE_SUBS 0x4 #define TYPE_QUOTE 0x8 #define TYPE_CLOSE_PAREN 0x10 #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 #define CHAR_TYPE(c) (tclCharTypeTable+128)[(int)(c)] MODULE_SCOPE const char tclCharTypeTable[]; |
Changes to generic/tclPathObj.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
Tcl_Obj *copyPtr);
static void FreeFsPathInternalRep(Tcl_Obj *pathPtr);
static void UpdateStringOfFsPath(Tcl_Obj *pathPtr);
static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static int FindSplitPos(const char *path, int separator);
static int IsSeparatorOrNull(int ch);
static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
/*
* Define the 'path' object type, which Tcl uses to represent file paths
* internally.
*/
static const Tcl_ObjType tclFsPathType = {
| > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
Tcl_Obj *copyPtr);
static void FreeFsPathInternalRep(Tcl_Obj *pathPtr);
static void UpdateStringOfFsPath(Tcl_Obj *pathPtr);
static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static int FindSplitPos(const char *path, int separator);
static int IsSeparatorOrNull(int ch);
static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
static int MakePathFromNormalized(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
/*
* Define the 'path' object type, which Tcl uses to represent file paths
* internally.
*/
static const Tcl_ObjType tclFsPathType = {
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
TclFSNormalizeToUniquePath(interp, retVal, 0);
/*
* Since we know it is a normalized path, we can actually convert this
* object into an FsPath for greater efficiency
*/
| | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
TclFSNormalizeToUniquePath(interp, retVal, 0);
/*
* Since we know it is a normalized path, we can actually convert this
* object into an FsPath for greater efficiency
*/
MakePathFromNormalized(interp, retVal);
/*
* This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs.
*/
return retVal;
}
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
Tcl_Interp *interp, /* Used for error reporting */
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
if (pathPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
| < | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
Tcl_Interp *interp, /* Used for error reporting */
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
if (pathPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0) {
switch (portion) {
case TCL_PATH_DIRNAME: {
/*
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'dirname' would be a joining of the main
* part with the dirname of the joined-on bit. We could handle
* that special case here, but we don't, and instead just use
|
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 |
TclNewFSPathObj(
Tcl_Obj *dirPtr,
const char *addStrRep,
int len)
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
| < | 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
TclNewFSPathObj(
Tcl_Obj *dirPtr,
const char *addStrRep,
int len)
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
const char *p;
int state = 0, count = 0;
/* [Bug 2806250] - this is only a partial solution of the problem.
* The PATHFLAGS != 0 representation assumes in many places that
* the "tail" part stored in the normPathPtr field is itself a
* relative path. Strings that begin with "~" are not relative paths,
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 |
Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len);
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
| < < | | 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 |
Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len);
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
pathPtr = Tcl_NewObj();
fsPathPtr = ckalloc(sizeof(FsPath));
/*
* Set up the path.
*/
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->cwdPtr = dirPtr;
Tcl_IncrRefCount(dirPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
fsPathPtr->filesystemEpoch = 0;
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
pathPtr->typePtr = &tclFsPathType;
pathPtr->bytes = NULL;
pathPtr->length = 0;
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 |
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
| | | | < | < | | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 |
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
* MakePathFromNormalized --
*
* Like SetFsPathFromAny, but assumes the given object is an absolute
* normalized path. Only for internal use.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
MakePathFromNormalized(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
if (pathPtr->typePtr == &tclFsPathType) {
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);
}
|
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 |
* Circular reference by design.
*/
fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
| > | | 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
* Circular reference by design.
*/
fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
/* Remember the epoch under which we decided pathPtr was normalized */
fsPathPtr->filesystemEpoch = TclFSEpoch();
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 |
Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
ClientData clientData)
{
Tcl_Obj *pathPtr = NULL;
FsPath *fsPathPtr;
| < | 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
ClientData clientData)
{
Tcl_Obj *pathPtr = NULL;
FsPath *fsPathPtr;
if (fromFilesystem->internalToNormalizedProc != NULL) {
pathPtr = (*fromFilesystem->internalToNormalizedProc)(clientData);
}
if (pathPtr == NULL) {
return NULL;
}
|
| ︙ | ︙ | |||
1598 1599 1600 1601 1602 1603 1604 |
* Circular reference, by design.
*/
fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
| | | 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 |
* Circular reference, by design.
*/
fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
fsPathPtr->filesystemEpoch = TclFSEpoch();
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
pathPtr->typePtr = &tclFsPathType;
return pathPtr;
}
|
| ︙ | ︙ | |||
1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
if (translatedCwdPtr == NULL) {
return NULL;
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
srcFsPathPtr->translatedPathPtr = retObj;
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.
| > > > > > > | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 |
if (translatedCwdPtr == NULL) {
return NULL;
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
srcFsPathPtr->translatedPathPtr = retObj;
if (translatedCwdPtr->typePtr == &tclFsPathType) {
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.
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 |
if (PATHFLAGS(pathPtr) != 0) {
/*
* This is a special path object which is the result of something like
* 'file join'
*/
Tcl_Obj *dir, *copy;
| | > > | > > > | 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 |
if (PATHFLAGS(pathPtr) != 0) {
/*
* This is a special path object which is the result of something like
* 'file join'
*/
Tcl_Obj *dir, *copy;
int tailLen, cwdLen, pathType;
pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
/* TODO: Figure out why this is needed. */
if (pathPtr->bytes == NULL) {
UpdateStringOfFsPath(pathPtr);
}
Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
copy = Tcl_DuplicateObj(dir);
}
Tcl_IncrRefCount(dir);
Tcl_IncrRefCount(copy);
/*
* We now own a reference on both 'dir' and 'copy'
*/
|
| ︙ | ︙ | |||
2199 2200 2201 2202 2203 2204 2205 |
void
TclFSSetPathDetails(
Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr,
ClientData clientData)
{
| < | | 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 |
void
TclFSSetPathDetails(
Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr,
ClientData clientData)
{
FsPath *srcFsPathPtr;
/*
* Make sure pathPtr is of the correct type.
*/
if (pathPtr->typePtr != &tclFsPathType) {
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return;
}
}
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->fsPtr = fsPtr;
srcFsPathPtr->nativePathPtr = clientData;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSEqualPaths --
*
|
| ︙ | ︙ | |||
2304 2305 2306 2307 2308 2309 2310 |
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
| < | 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 |
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
if (pathPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
|
| ︙ | ︙ | |||
2363 2364 2365 2366 2367 2368 2369 |
if (split != len) {
name[split] = separator;
}
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
| | | | | < | | 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 |
if (split != len) {
name[split] = separator;
}
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't find HOME environment variable to"
" expand path", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
"HOMELESS", NULL);
}
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/*
* We have a user name '~user'
*/
Tcl_DStringInit(&temp);
if (TclpGetUserHome(name+1, &temp) == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", name+1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
NULL);
}
Tcl_DStringFree(&temp);
if (split != len) {
name[split] = separator;
}
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 |
*/
fsPathPtr = ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
if (transPtr != pathPtr) {
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
}
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
| > > > > < | 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 |
*/
fsPathPtr = ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
if (transPtr != pathPtr) {
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
/* Redo translation when $env(HOME) changes */
fsPathPtr->filesystemEpoch = TclFSEpoch();
} else {
fsPathPtr->filesystemEpoch = 0;
}
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);
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
if (file == NULL) {
Tcl_Obj *msg;
Tcl_GetChannelError(chan, &msg);
if (msg) {
Tcl_SetObjResult(interp, msg);
} else {
| | > | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
if (file == NULL) {
Tcl_Obj *msg;
Tcl_GetChannelError(chan, &msg);
if (msg) {
Tcl_SetObjResult(interp, msg);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for %s",
Tcl_GetChannelName(chan),
((writing) ? "writing" : "reading")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADCHAN", NULL);
}
return NULL;
}
*releasePtr = 1;
if (writing) {
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
name = Tcl_TranslateFileName(interp, spec, &nameString);
if (name == NULL) {
return NULL;
}
file = TclpOpenFile(name, flags);
Tcl_DStringFree(&nameString);
if (file == NULL) {
| | > | | | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
name = Tcl_TranslateFileName(interp, spec, &nameString);
if (name == NULL) {
return NULL;
}
file = TclpOpenFile(name, flags);
Tcl_DStringFree(&nameString);
if (file == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't %s file \"%s\": %s",
(writing ? "write" : "read"), spec,
Tcl_PosixError(interp)));
return NULL;
}
*closePtr = 1;
}
return file;
badLastArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command", arg));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 | * 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?)"; } | > | < | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | * 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)); } continue; } /* * Create error messages for unusual process exits. An extra newline * gets appended to each error message, but it gets removed below (in |
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
} 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);
| > | > | < | | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
} 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);
}
}
}
}
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET);
objPtr = Tcl_NewObj();
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
| > | | > | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET);
objPtr = Tcl_NewObj();
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading stderr output file: %s",
Tcl_PosixError(interp)));
} else if (count > 0) {
anyErrorInfo = 1;
Tcl_SetObjResult(interp, objPtr);
result = TCL_ERROR;
} else {
Tcl_DecrRefCount(objPtr);
}
}
Tcl_Close(NULL, errorChan);
}
/*
* If a child exited abnormally but didn't output any error information at
* all, generate an error message here.
*/
if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"child process exited abnormally", -1));
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
switch (*p++) {
case '|':
if (*p == '&') {
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
| > | < | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
switch (*p++) {
case '|':
if (*p == '&') {
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
}
}
lastBar = i;
cmdCount++;
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
if (*p == '<') {
inputFile = NULL;
inputLiteral = p + 1;
skip = 1;
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
| | | > | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
if (*p == '<') {
inputFile = NULL;
inputLiteral = p + 1;
skip = 1;
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
}
skip = 2;
}
} else {
|
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
/*
* Special case handling of 2>@1 to redirect stderr to the
* exec/open output pipe as well. This is meant for the end of
* the command string, otherwise use |& between commands.
*/
if (i != argc-1) {
| | | > | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 |
/*
* Special case handling of 2>@1 to redirect stderr to the
* exec/open output pipe as well. This is meant for the end of
* the command string, otherwise use |& between commands.
*/
if (i != argc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"must specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"PIPESYNTAX", NULL);
goto error;
}
errorFile = outputFile;
errorToOutput = 2;
skip = 1;
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
}
if (needCmd) {
/*
* We had a bar followed only by redirections.
*/
| > | < | | | | | | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
}
if (needCmd) {
/*
* We had a bar followed only by redirections.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
NULL);
goto error;
}
if (inputFile == NULL) {
if (inputLiteral != NULL) {
/*
* The input for the first process is immediate data coming from
* Tcl. Create a temporary file for it and put the data into the
* file.
*/
inputFile = TclpCreateTempFile(inputLiteral);
if (inputFile == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create input file for command: %s",
Tcl_PosixError(interp)));
goto error;
}
inputClose = 1;
} else if (inPipePtr != NULL) {
/*
* The input for the first process in the pipeline is to come from
* a pipe that can be written from by the caller.
*/
if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create input pipe for command: %s",
Tcl_PosixError(interp)));
goto error;
}
inputClose = 1;
} else {
/*
* The input for the first process comes from stdin.
*/
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 |
if (outPipePtr != NULL) {
/*
* Output from the last process in the pipeline is to go to a pipe
* that can be read by the caller.
*/
if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
| | | | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 |
if (outPipePtr != NULL) {
/*
* Output from the last process in the pipeline is to go to a pipe
* that can be read by the caller.
*/
if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create output pipe for command: %s",
Tcl_PosixError(interp)));
goto error;
}
outputClose = 1;
} else {
/*
* The output for the last process goes to stdout.
*/
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 |
* cause the pipeline to deadlock: we'd be waiting for processes
* to complete before reading stderr, and processes couldn't
* complete because stderr was backed up.
*/
errorFile = TclpCreateTempFile(NULL);
if (errorFile == NULL) {
| | | | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 |
* cause the pipeline to deadlock: we'd be waiting for processes
* to complete before reading stderr, and processes couldn't
* complete because stderr was backed up.
*/
errorFile = TclpCreateTempFile(NULL);
if (errorFile == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create error file for command: %s",
Tcl_PosixError(interp)));
goto error;
}
*errFilePtr = errorFile;
} else {
/*
* Errors from the pipeline go to stderr.
*/
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 |
*/
if (lastArg == argc) {
curOutFile = outputFile;
} else {
argv[lastArg] = NULL;
if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
| | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 |
*/
if (lastArg == argc) {
curOutFile = outputFile;
} else {
argv[lastArg] = NULL;
if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create pipe: %s", Tcl_PosixError(interp)));
goto error;
}
}
if (joinThisError != 0) {
curErrFile = curOutFile;
} else {
|
| ︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 |
/*
* Verify that the pipes that were created satisfy the readable/writable
* constraints.
*/
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
| > | | > | | > | < | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
/*
* Verify that the pipes that were created satisfy the readable/writable
* constraints.
*/
if (flags & TCL_ENFORCE_MODE) {
if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't read output from command:"
" standard output was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't write input to command:"
" standard input was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
"BADREDIRECT", NULL);
goto error;
}
}
channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
numPids, pidPtr);
if (channel == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"pipe for command could not be created", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
goto error;
}
return channel;
error:
if (numPids > 0) {
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
if (res == 0) {
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
| > | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
if (res == 0) {
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"conflicting versions provided for package \"%s\": %s, then %s",
name, pkgPtr->version, version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 | * 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. */ tclEmptyStringRep = &tclEmptyString; | | | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
* 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.
*/
tclEmptyStringRep = &tclEmptyString;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Cannot load package \"%s\" in standalone executable:"
" This package is not compiled with stub support", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
return NULL;
}
/*
* Translate between old and new API, and defer to the new function.
*/
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion;
/* Internal rep. of versions */
int availStable, code, satisfies, pass;
char *script, *pkgVersionI;
Tcl_DString command;
/*
* It can take up to three passes to find the package: one pass to run the
* "package unknown" script, one to run the "package ifneeded" script for
* a specific version, and a final pass to lookup the package loaded by
* the "package ifneeded" script.
*/
for (pass=1 ;; pass++) {
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version != NULL) {
break;
}
/*
* Check whether we're already attempting to load some version of this
* package (circular dependency detection).
*/
if (pkgPtr->clientData != NULL) {
| > > > > > | | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion;
/* Internal rep. of versions */
int availStable, code, satisfies, pass;
char *script, *pkgVersionI;
Tcl_DString command;
if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) {
return NULL;
}
/*
* It can take up to three passes to find the package: one pass to run the
* "package unknown" script, one to run the "package ifneeded" script for
* a specific version, and a final pass to lookup the package loaded by
* the "package ifneeded" script.
*/
for (pass=1 ;; pass++) {
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version != NULL) {
break;
}
/*
* Check whether we're already attempting to load some version of this
* package (circular dependency detection).
*/
if (pkgPtr->clientData != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"circular package dependency:"
" attempt to provide %s %s requires %s",
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
return NULL;
}
/*
* The package isn't yet present. Search the list of available
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 |
Tcl_Release(script);
pkgPtr = FindPackage(interp, name);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
code = TCL_ERROR;
| > | < | | | | > | | < | | | | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
Tcl_Release(script);
pkgPtr = FindPackage(interp, name);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
code = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" no version of package %s provided",
name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
NULL);
} else {
char *pvi, *vi;
if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
NULL) != TCL_OK) {
code = TCL_ERROR;
} else if (CheckVersionAndConvert(interp,
versionToProvide, &vi, NULL) != TCL_OK) {
ckfree(pvi);
code = TCL_ERROR;
} else {
int res = CompareVersions(pvi, vi, NULL);
ckfree(pvi);
ckfree(vi);
if (res != 0) {
code = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" package %s %s provided instead",
name, versionToProvide,
name, pkgPtr->version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
}
}
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" bad return code: %s",
name, versionToProvide, TclGetString(codePtr)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
TclDecrRefCount(codePtr);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
AddRequirementsToDString(&command, reqc, reqv);
code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
| < < | | < < > | > | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
AddRequirementsToDString(&command, reqc, reqv);
code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad return code: %d", code));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (\"package unknown\" script)");
return NULL;
}
Tcl_ResetResult(interp);
}
}
if (pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
AddRequirementsToResult(interp, reqc, reqv);
return NULL;
}
/*
* At this point we know that the package is present. Make sure that the
* provided version meets the current requirements.
*/
if (reqc != 0) {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
if (!satisfies) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"version conflict for package \"%s\": have %s, need",
name, pkgPtr->version));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
NULL);
AddRequirementsToResult(interp, reqc, reqv);
return NULL;
}
}
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
NULL);
}
return foundVersion;
}
}
if (version != NULL) {
| | | > | | 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
NULL);
}
return foundVersion;
}
}
if (version != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package %s %s is not present", name, version));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package %s is not present", name));
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 |
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
if (res == 0){
if (objc == 4) {
ckfree(argv3i);
| > | | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
if (res == 0){
if (objc == 4) {
ckfree(argv3i);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
break;
}
}
ckfree(argv3i);
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 |
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
| > | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(pkgPtr->version, -1));
}
}
return TCL_OK;
}
argv3 = TclGetString(objv[3]);
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 |
}
break;
case PKG_UNKNOWN: {
int length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
| > | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
}
break;
case PKG_UNKNOWN: {
int length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
argv2 = Tcl_GetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
|
| ︙ | ︙ | |||
1347 1348 1349 1350 1351 1352 1353 |
*stable = !hasunstable;
}
return TCL_OK;
}
error:
ckfree(ibuf);
| > | < | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 |
*stable = !hasunstable;
}
return TCL_OK;
}
error:
ckfree(ibuf);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected version number but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 |
}
if (strchr(dash+1, '-') != NULL) {
/*
* More dashes found after the first. This is wrong.
*/
| > | < | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 |
}
if (strchr(dash+1, '-') != NULL) {
/*
* More dashes found after the first. This is wrong.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected versionMin-versionMax but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
return TCL_ERROR;
}
/*
* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
|
| ︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 |
AddRequirementsToResult(
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
| | | | < | | | | | | < | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 |
AddRequirementsToResult(
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i, length;
for (i = 0; i < reqc; i++) {
const char *v = Tcl_GetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
} else {
Tcl_AppendPrintfToObj(result, " %s", v);
}
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 |
AddRequirementsToDString(
Tcl_DString *dsPtr,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
| < | > | | | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
AddRequirementsToDString(
Tcl_DString *dsPtr,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
int i;
if (reqc > 0) {
for (i = 0; i < reqc; i++) {
TclDStringAppendLiteral(dsPtr, " ");
TclDStringAppendObj(dsPtr, reqv[i]);
}
} else {
TclDStringAppendLiteral(dsPtr, " 0-");
}
}
/*
*----------------------------------------------------------------------
*
* SomeRequirementSatisfied --
|
| ︙ | ︙ |
Changes to generic/tclPlatDecls.h.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 |
const char *bundleVersion,
int hasResourceFile, int maxPathLen,
char *libraryPath);
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
| | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
const char *bundleVersion,
int hasResourceFile, int maxPathLen,
char *libraryPath);
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
void *hooks;
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
|
| ︙ | ︙ |
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
*/
fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
| | | > | | > > | | < | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
*/
fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\" in non-global namespace with"
" name starting with \":\"", procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
* qualifiers. To create the new command in the right namespace, we
* generate a fully qualified name for it.
*/
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
| | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
* qualifiers. To create the new command in the right namespace, we
* generate a fully qualified name for it.
*/
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, procName, -1);
cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
TclNRInterpProc, procPtr, TclProcDeleteProc);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 |
result = Tcl_SplitList(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
ckfree(fieldValues);
| | | | > | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
result = Tcl_SplitList(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
ckfree(fieldValues);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"too many fields in argument specifier \"%s\"",
argArray[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
ckfree(fieldValues);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
nameLength = strlen(fieldValues[0]);
if (fieldCount == 2) {
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 |
if (*p == '(') {
const char *q = p;
do {
q++;
} while (*q != '\0');
q--;
if (*q == ')') { /* We have an array element. */
| > | | > | | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
if (*p == '(') {
const char *q = p;
do {
q++;
} while (*q != '\0');
q--;
if (*q == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
fieldValues[0]));
ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is not a simple name",
fieldValues[0]));
ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
p++;
}
|
| ︙ | ︙ | |||
763 764 765 766 767 768 769 |
goto levelError;
}
*framePtrPtr = framePtr;
return result;
levelError:
| | < | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
if (framePtr == NULL) {
goto levelError;
}
*framePtrPtr = framePtr;
return result;
levelError:
| | < | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1875 1876 1877 1878 1879 1880 1881 |
case TCL_CONTINUE:
case TCL_BREAK:
/*
* It's an error to get to this point from a 'break' or 'continue', so
* transform to an error now.
*/
| | | | < | 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 |
case TCL_CONTINUE:
case TCL_BREAK:
/*
* It's an error to get to this point from a 'break' or 'continue', so
* transform to an error now.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invoked \"%s\" outside of a loop",
((result == TCL_BREAK) ? "break" : "continue")));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
/*
* Fall through to the TCL_ERROR handling code.
*/
|
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 |
&& (codePtr->nsPtr == nsPtr)
&& (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
return TCL_OK;
}
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
| | | | 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 |
&& (codePtr->nsPtr == nsPtr)
&& (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
return TCL_OK;
}
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a precompiled script jumped interps", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"CROSSINTERPBYTECODE", NULL);
return TCL_ERROR;
}
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
|
| ︙ | ︙ | |||
2928 2929 2930 2931 2932 2933 2934 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procName");
return TCL_ERROR;
}
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
| | | | 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procName");
return TCL_ERROR;
}
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
/*
* Compile (if uncompiled) and disassemble a procedure.
|
| ︙ | ︙ | |||
2978 2979 2980 2981 2982 2983 2984 |
*/
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
| | | | 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 |
*/
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
(char *) objv[3]);
goto methodBody;
|
| ︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 |
/*
* Compile (if necessary) and disassemble a method body.
*/
methodBody:
if (hPtr == NULL) {
unknownMethod:
| | | | | | 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 |
/*
* Compile (if necessary) and disassemble a method body.
*/
methodBody:
if (hPtr == NULL) {
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
}
if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
Command cmd;
|
| ︙ | ︙ | |||
3057 3058 3059 3060 3061 3062 3063 |
/*
* Do the actual disassembly.
*/
if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
& TCL_BYTECODE_PRECOMPILED) {
| > | | 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 |
/*
* Do the actual disassembly.
*/
if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->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;
}
Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclRegexp.c.
| ︙ | ︙ | |||
710 711 712 713 714 715 716 |
void
TclRegError(
Tcl_Interp *interp, /* Interpreter for error reporting. */
const char *msg, /* Message to prepend to error. */
int status) /* Status code to report. */
{
char buf[100]; /* ample in practice */
| | | | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
void
TclRegError(
Tcl_Interp *interp, /* Interpreter for error reporting. */
const char *msg, /* Message to prepend to error. */
int status) /* Status code to report. */
{
char buf[100]; /* ample in practice */
char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
n = TclReError(status, NULL, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
sprintf(cbuf, "%d", status);
(void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf));
Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
}
/*
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
Tcl_DiscardResult(
Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
| | < | | | < | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
Tcl_DiscardResult(
Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
} else if (statePtr->freeProc == TCL_DYNAMIC) {
ckfree(statePtr->result);
} else if (statePtr->freeProc) {
statePtr->freeProc(statePtr->result);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetResult --
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 |
int length;
/*
* If the string result is non-empty, move the string result to the object
* result, then reset the string result.
*/
| | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
int length;
/*
* If the string result is non-empty, move the string result to the object
* result, then reset the string result.
*/
if (iPtr->result[0] != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->result[0] = 0;
}
return iPtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1102 1103 1104 1105 1106 1107 1108 | } /* *---------------------------------------------------------------------- * * Tcl_GetErrorLine -- * | | < < | < < | 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetErrorLine --
*
* Returns the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetErrorLine(
Tcl_Interp *interp)
{
return ((Interp *) interp)->errorLine;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorLine --
*
* Sets the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorLine(
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
}
if (code == TCL_ERROR) {
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
| | > | > > > | > > > | > > | > | > | > | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 |
}
if (code == TCL_ERROR) {
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
int infoLen;
(void) TclGetStringFromObj(valuePtr, &infoLen);
if (infoLen) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
if (valuePtr != NULL) {
int len, valueObjc;
Tcl_Obj **valueObjv;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
/*
* List extraction done after duplication to avoid moving the rug
* if someone does [return -errorstack [info errorstack]]
*/
if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list intrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
valueObjv);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
&valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
Tcl_SetErrorCode(interp, "NONE", NULL);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
&valuePtr);
if (valuePtr != NULL) {
TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
}
if (level != 0) {
iPtr->returnLevel = level;
iPtr->returnCode = code;
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
nestedOptions:
if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
&keyPtr, &valuePtr, &done)) {
/*
* Value is not a legal dictionary.
*/
| | < | | | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
nestedOptions:
if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search,
&keyPtr, &valuePtr, &done)) {
/*
* Value is not a legal dictionary.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad %s value: expected dictionary but got \"%s\"",
compare, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
NULL);
goto error;
}
while (!done) {
Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
/*
* Check for bogus -code value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if (valuePtr != NULL) {
| | > | < | | | | | | > | | | < | | | | | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
/*
* Check for bogus -code value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if (valuePtr != NULL) {
if (TclGetCompletionCodeFromObj(interp, valuePtr,
&code) == TCL_ERROR) {
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
}
/*
* Check for bogus -level value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
if (valuePtr != NULL) {
if ((TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &level))
|| (level < 0)) {
/*
* Value is not a legal level.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -level value: expected non-negative integer but got"
" \"%s\"", TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
}
/*
* Check for bogus -errorcode value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
int length;
if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorcode.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorcode value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
NULL);
goto error;
}
}
/*
* Check for bogus -errorstack value.
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
if (valuePtr != NULL) {
int length;
if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorstack.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorstack value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
NULL);
goto error;
}
if (length % 2) {
/*
* Errorstack must always be an even-sized list
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"forbidden odd-sized list for -errorstack: \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT",
"ODDSIZEDLIST_ERRORSTACK", NULL);
goto error;
}
}
/*
|
| ︙ | ︙ | |||
1597 1598 1599 1600 1601 1602 1603 | } /* *------------------------------------------------------------------------- * * TclNoErrorStack -- * | | > | > > < | 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 |
}
/*
*-------------------------------------------------------------------------
*
* TclNoErrorStack --
*
* Removes the -errorstack entry from an options dict to avoid reference
* cycles.
*
* Results:
* The (unshared) argument options dict, modified in -place.
*
*-------------------------------------------------------------------------
*/
Tcl_Obj *
TclNoErrorStack(
Tcl_Interp *interp,
Tcl_Obj *options)
{
Tcl_Obj **keys = GetKeys();
Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]);
return options;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_SetReturnOptions --
|
| ︙ | ︙ | |||
1646 1647 1648 1649 1650 1651 1652 |
{
int objc, level, code;
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
| | < | | 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
{
int objc, level, code;
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected dict but got \"%s\"", TclGetString(options)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
code = TCL_ERROR;
} else {
code = TclProcessReturn(interp, code, level, mergedOpts);
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
| ︙ | ︙ | |||
257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch;
int objIndex, xpgSize, nspace = numVars;
int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
char buf[TCL_UTF_MAX+1];
/*
* Initialize an array that records the number of times a variable is
* assigned to by the format string. We use this to detect if a variable
* is multiply assigned or left unassigned.
*/
| > > > > | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch;
int objIndex, xpgSize, nspace = numVars;
int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
char buf[TCL_UTF_MAX+1];
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! */
/*
* Initialize an array that records the number of times a variable is
* assigned to by the format string. We use this to detect if a variable
* is multiply assigned or left unassigned.
*/
|
| ︙ | ︙ | |||
324 325 326 327 328 329 330 |
goto xpgCheckDone;
}
notXpg:
gotSequential = 1;
if (gotXpg) {
mixedXPG:
| | | | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
goto xpgCheckDone;
}
notXpg:
gotSequential = 1;
if (gotXpg) {
mixedXPG:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot mix \"%\" and \"%n$\" conversion specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
goto error;
}
xpgCheckDone:
/*
* Parse any width specifier.
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
/*
* Handle the various field types.
*/
switch (ch) {
case 'c':
if (flags & SCAN_WIDTH) {
| | | | | > | > | | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
/*
* Handle the various field types.
*/
switch (ch) {
case 'c':
if (flags & SCAN_WIDTH) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
/*
* Fall through!
*/
case 'n':
case 's':
if (flags & (SCAN_LONGER|SCAN_BIG)) {
invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
errorMsg = Tcl_NewStringObj(
"field size modifier may not be specified in %", -1);
Tcl_AppendToObj(errorMsg, buf, -1);
Tcl_AppendToObj(errorMsg, " conversion", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
goto error;
}
/*
* Fall through!
*/
case 'd':
case 'e':
case 'f':
case 'g':
case 'i':
case 'o':
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
*/
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
if (*format == '\0') {
goto badSet;
}
format += Tcl_UtfToUniChar(format, &ch);
}
break;
badSet:
| > | < | > | > | > | | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
if (*format == '\0') {
goto badSet;
}
format += Tcl_UtfToUniChar(format, &ch);
}
break;
badSet:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched [ in format string", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
goto error;
default:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
errorMsg = Tcl_NewStringObj(
"bad scan conversion character \"", -1);
Tcl_AppendToObj(errorMsg, buf, -1);
Tcl_AppendToObj(errorMsg, "\"", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
goto error;
}
if (!(flags & SCAN_SUPPRESS)) {
if (objIndex >= nspace) {
/*
* Expand the nassign buffer. If we are using XPG specifiers,
* make sure that we grow to a large enough size. xpgSize is
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 |
}
}
if (totalSubs) {
*totalSubs = numVars;
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
| | | | | > | < | | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
}
}
if (totalSubs) {
*totalSubs = numVars;
}
for (i = 0; i < numVars; i++) {
if (nassign[i] > 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is assigned by multiple \"%n$\" conversion specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
/*
* If the space is empty, and xpgSize is 0 (means XPG wasn't used,
* and/or numVars != 0), then too many vars were given
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is not assigned by any conversion specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
goto error;
}
}
TclStackFree(interp, nassign);
return TCL_OK;
badIndex:
if (gotXpg) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"%n$\" argument index out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"different numbers of variable names and field specifiers",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
}
error:
TclStackFree(interp, nassign);
return TCL_ERROR;
}
|
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
static int TclSockMinimumBuffersOld(int sock, int size)
{
return TclSockMinimumBuffers(INT2PTR(sock), size);
}
#endif
#ifdef __WIN32__
# define TclUnixWaitForFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty TclPlatIsAtty
# define TclWinSetInterfaces (void (*) (int)) doNothing
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
| > > > > > > > > > > > > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
#define TclBackgroundException Tcl_BackgroundException
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
static int TclSockMinimumBuffersOld(int sock, int size)
{
return TclSockMinimumBuffers(INT2PTR(sock), size);
}
#endif
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
#endif
#ifdef __WIN32__
# define TclUnixWaitForFile 0
# define TclUnixCopyFile 0
# define TclUnixOpenTemporaryFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty TclPlatIsAtty
# define TclWinSetInterfaces (void (*) (int)) doNothing
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const char *)&winTCharEncoding, &hInstance);
return hInstance;
}
| < < < < < < | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const char *)&winTCharEncoding, &hInstance);
return hInstance;
}
int
TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
{
return setsockopt((int) s, level, optname, optval, optlen);
}
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_ExternalToUtfDString(winTCharEncoding,
string, len, dsPtr);
}
| < < < < < < < < | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_ExternalToUtfDString(winTCharEncoding,
string, len, dsPtr);
}
#else /* UNIX and MAC */
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
#endif
/*
* WARNING: The contents of this file is automatically generated by the
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
0, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
| | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
0, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
Tcl_SetStartupScript, /* 178 */
Tcl_GetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
0, /* 184 */
0, /* 185 */
0, /* 186 */
|
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
TclPtrMakeUpvar, /* 229 */
TclObjLookupVar, /* 230 */
TclGetNamespaceFromObj, /* 231 */
TclEvalObjEx, /* 232 */
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
| | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
TclPtrMakeUpvar, /* 229 */
TclObjLookupVar, /* 230 */
TclGetNamespaceFromObj, /* 231 */
TclEvalObjEx, /* 232 */
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
TclResetCancellation, /* 237 */
TclNRInterpProc, /* 238 */
TclNRInterpProcCore, /* 239 */
TclNRRunCallbacks, /* 240 */
TclNREvalObjEx, /* 241 */
TclNREvalObjv, /* 242 */
TclDbDumpActiveObjects, /* 243 */
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
TclUnixWaitForFile, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
TclWinGetPlatformId, /* 9 */
TclpReaddir, /* 10 */
TclGetAndDetachPids, /* 11 */
TclpCloseFile, /* 12 */
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
TclpIsAtty, /* 16 */
| > | > | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* UNIX */
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
TclUnixWaitForFile, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
TclWinGetPlatformId, /* 9 */
TclpReaddir, /* 10 */
TclGetAndDetachPids, /* 11 */
TclpCloseFile, /* 12 */
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
TclpIsAtty, /* 16 */
TclUnixCopyFile, /* 17 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
TclpInetNtoa, /* 21 */
TclpCreateTempFile, /* 22 */
0, /* 23 */
TclWinNoBackslash, /* 24 */
0, /* 25 */
TclWinSetInterfaces, /* 26 */
TclWinFlushDirtyChannels, /* 27 */
TclWinResetInterfaces, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
| > | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* MACOSX */
};
static const TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
0,
#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 |
Tcl_GetStartupScript, /* 623 */
Tcl_CloseEx, /* 624 */
Tcl_NRExprObj, /* 625 */
Tcl_NRSubstObj, /* 626 */
Tcl_LoadFile, /* 627 */
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
};
/* !END!: Do not edit above this line. */
| > | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 |
Tcl_GetStartupScript, /* 623 */
Tcl_CloseEx, /* 624 */
Tcl_NRExprObj, /* 625 */
Tcl_NRSubstObj, /* 626 */
Tcl_LoadFile, /* 627 */
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLib.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < < < < < < < < < < < < < < < < < < < < < < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
/*
* tclStubLib.c --
*
* Stub object that will be statically linked into extensions that want
* to access Tcl.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 1998 Paul Duffin.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
MODULE_SCOPE const TclStubs *tclStubsPtr;
MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr;
MODULE_SCOPE const TclIntStubs *tclIntStubsPtr;
MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr;
const TclStubs *tclStubsPtr = NULL;
const TclPlatStubs *tclPlatStubsPtr = NULL;
const TclIntStubs *tclIntStubsPtr = NULL;
const TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
/*
* Use our own isDigit to avoid linking to libc on windows
*/
static int isDigit(const int c)
{
return (c >= '0' && c <= '9');
}
|
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | * indicate that an error occurred. * * Side effects: * Sets the stub table pointers. * *---------------------------------------------------------------------- */ | | > > | > | | | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
* indicate that an error occurred.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
#undef Tcl_InitStubs
MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
int exact)
{
Interp *iPtr = (Interp *) interp;
const char *actualVersion = NULL;
ClientData pkgData = NULL;
const TclStubs *stubsPtr = iPtr->stubTable;
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) {
iPtr->result = "interpreter uses an incompatible stubs mechanism";
iPtr->freeProc = TCL_STATIC;
return NULL;
}
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
if (exact) {
const char *p = version;
int count = 0;
while (*p) {
count += !isDigit(*p++);
}
if (count == 1) {
const char *q = actualVersion;
p = version;
while (*p && (*p == *q)) {
p++; q++;
}
if (*p || isDigit(*q)) {
/* Construct error message */
stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
return NULL;
}
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
tclStubsPtr = (TclStubs *)pkgData;
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1998-2000 Ajuba Solutions. * Copyright (c) 2003 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. */ | < < < < < > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | * Copyright (c) 1998-2000 Ajuba Solutions. * Copyright (c) 2003 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. */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include <sys/stat.h> #include "tclInt.h" #include "tclOO.h" #include <math.h> /* * Required for Testregexp*Cmd */ |
| ︙ | ︙ | |||
309 310 311 312 313 314 315 | Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); | < < < | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparsevarObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestparsevarnameObjCmd(ClientData dummy, |
| ︙ | ︙ | |||
385 386 387 388 389 390 391 | static Tcl_FSLstatProc TestReportLstat; static Tcl_FSCopyFileProc TestReportCopyFile; static Tcl_FSDeleteFileProc TestReportDeleteFile; static Tcl_FSRenameFileProc TestReportRenameFile; static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; | | > | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | static Tcl_FSLstatProc TestReportLstat; static Tcl_FSCopyFileProc TestReportCopyFile; static Tcl_FSDeleteFileProc TestReportDeleteFile; static Tcl_FSRenameFileProc TestReportRenameFile; static Tcl_FSCreateDirectoryProc TestReportCreateDirectory; static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; static int TestReportLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); static Tcl_FSLinkProc TestReportLink; static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet; static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; |
| ︙ | ︙ | |||
418 419 420 421 422 423 424 | Tcl_Obj *const objv[]); static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #if defined(HAVE_CPUID) || defined(__WIN32__) static int TestcpuidCmd(ClientData dummy, Tcl_Interp* interp, int objc, | | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
Tcl_Obj *const objv[]);
static int TestInterpResolverCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
#if defined(HAVE_CPUID) || defined(__WIN32__)
static int TestcpuidCmd(ClientData dummy,
Tcl_Interp* interp, int objc,
Tcl_Obj *const objv[]);
#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
TestReportInFilesystem, /* path in */
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 |
TestReportCreateDirectory,
TestReportRemoveDirectory,
TestReportDeleteFile,
TestReportCopyFile,
TestReportRenameFile,
TestReportCopyDirectory,
TestReportLstat,
| | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
TestReportCreateDirectory,
TestReportRemoveDirectory,
TestReportDeleteFile,
TestReportCopyFile,
TestReportRenameFile,
TestReportCopyDirectory,
TestReportLstat,
(Tcl_FSLoadFileProc *) TestReportLoadFile,
NULL /* cwd */,
TestReportChdir
};
static const Tcl_Filesystem simpleFilesystem = {
"simple",
sizeof(Tcl_Filesystem),
|
| ︙ | ︙ | |||
634 635 636 637 638 639 640 |
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
| < | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
TestgetvarfullnameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
NULL, NULL);
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
if (argc != 5) {
goto wrongNumArgs;
}
if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
|| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
return code;
#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_ThreadId threadID;
if (Tcl_CreateThread(&threadID, AsyncThreadProc,
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
return TCL_ERROR;
}
break;
}
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, mark, or marklater", NULL);
return TCL_ERROR;
#else /* !TCL_THREADS */
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
| > > > > > | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
if (argc != 5) {
goto wrongNumArgs;
}
if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
|| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_ThreadId threadID;
if (Tcl_CreateThread(&threadID, AsyncThreadProc,
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, mark, or marklater", NULL);
return TCL_ERROR;
#else /* !TCL_THREADS */
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
|
| ︙ | ︙ | |||
4543 4544 4545 4546 4547 4548 4549 |
argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
ckfree(argString);
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 |
argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
ckfree(argString);
return TCL_OK;
}
static int
TestfileCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
{
|
| ︙ | ︙ |
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
| > > > > > > > > > > > | 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "bug3598580") == 0) {
Tcl_Obj *listObjPtr, *elemObjPtr;
if (objc != 2) {
goto wrongNumArgs;
}
elemObjPtr = Tcl_NewIntObj(123);
listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
/* Replace the single list element through itself, nonsense but legal. */
Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
| < | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using something on our stack!
*/
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
|| 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) {
const char *arg = Tcl_GetString(objv[1]);
| > | | | 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
|| 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) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
| | | | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
|
| ︙ | ︙ |
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
/* 62 */
EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i);
/* 63 */
EXTERN int TclBN_mp_cnt_lsb(const mp_int *a);
typedef struct TclTomMathStubs {
int magic;
| | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
/* 62 */
EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i);
/* 63 */
EXTERN int TclBN_mp_cnt_lsb(const mp_int *a);
typedef struct TclTomMathStubs {
int magic;
void *hooks;
int (*tclBN_epoch) (void); /* 0 */
int (*tclBN_revision) (void); /* 1 */
int (*tclBN_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 2 */
int (*tclBN_mp_add_d) (mp_int *a, mp_digit b, mp_int *c); /* 3 */
int (*tclBN_mp_and) (mp_int *a, mp_int *b, mp_int *c); /* 4 */
void (*tclBN_mp_clamp) (mp_int *a); /* 5 */
|
| ︙ | ︙ |
Changes to generic/tclTomMathInterface.c.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
*----------------------------------------------------------------------
*/
extern void *
TclBNAlloc(
size_t x)
{
| | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
*----------------------------------------------------------------------
*/
extern void *
TclBNAlloc(
size_t x)
{
return (void *) ckalloc((unsigned int) x);
}
/*
*----------------------------------------------------------------------
*
* TclBNRealloc --
*
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
*/
void *
TclBNRealloc(
void *p,
size_t s)
{
| | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
*/
void *
TclBNRealloc(
void *p,
size_t s)
{
return (void *) ckrealloc((char *) p, (unsigned int) s);
}
/*
*----------------------------------------------------------------------
*
* TclBNFree --
*
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
*----------------------------------------------------------------------
*/
extern void
TclBNFree(
void *p)
{
| | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
*----------------------------------------------------------------------
*/
extern void
TclBNFree(
void *p)
{
ckree((char *) p);
}
#endif
/*
*----------------------------------------------------------------------
*
* TclBNInitBignumFromLong --
|
| ︙ | ︙ |
Changes to generic/tclTomMathStubLib.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclTomMathStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclTomMathStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; const TclTomMathStubs *tclTomMathStubsPtr = NULL; |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
int epoch, /* Stubs table epoch from the header files */
int revision) /* Stubs table revision number from the
* header files */
{
int exact = 0;
const char *packageName = "tcl::tommath";
const char *errMsg = NULL;
| | | | < | | | | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
int epoch, /* Stubs table epoch from the header files */
int revision) /* Stubs table revision number from the
* header files */
{
int exact = 0;
const char *packageName = "tcl::tommath";
const char *errMsg = NULL;
TclTomMathStubs *stubsPtr = NULL;
const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
} else if(stubsPtr->tclBN_epoch() != epoch) {
errMsg = "epoch number mismatch";
} else if(stubsPtr->tclBN_revision() != revision) {
errMsg = "requires a later revision";
} else {
tclTomMathStubsPtr = stubsPtr;
return actualVersion;
}
tclStubsPtr->tcl_ResetResult(interp);
tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
" (requested version ", version, ", actual version ",
actualVersion, "): ", errMsg, NULL);
return NULL;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
break;
}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
return TCL_OK;
badVarOps:
| | | > | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
break;
}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
return TCL_OK;
badVarOps:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad operations \"%s\": should be one or more of rwua",
flagOps));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
| > | | < | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" enter, leave, enterstep, or leavestep", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
| > | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" delete or rename", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
| > | | | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 |
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad operation list \"\": must be one or more of"
" array, read, unset, or write", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
|
| ︙ | ︙ | |||
1294 1295 1296 1297 1298 1299 1300 |
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
| | | | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 |
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
TclDStringAppendLiteral(&cmd, " rename");
} else if (flags & TCL_TRACE_DELETE) {
TclDStringAppendLiteral(&cmd, " delete");
}
/*
* Execute the command. We discard any object result the command
* returns.
*
* Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to other
|
| ︙ | ︙ | |||
1990 1991 1992 1993 1994 1995 1996 |
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
| | | | | | | | | | 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
TclDStringAppendLiteral(&cmd, " a");
} else if (flags & TCL_TRACE_READS) {
TclDStringAppendLiteral(&cmd, " r");
} else if (flags & TCL_TRACE_WRITES) {
TclDStringAppendLiteral(&cmd, " w");
} else if (flags & TCL_TRACE_UNSETS) {
TclDStringAppendLiteral(&cmd, " u");
}
} else {
#endif
if (flags & TCL_TRACE_ARRAY) {
TclDStringAppendLiteral(&cmd, " array");
} else if (flags & TCL_TRACE_READS) {
TclDStringAppendLiteral(&cmd, " read");
} else if (flags & TCL_TRACE_WRITES) {
TclDStringAppendLiteral(&cmd, " write");
} else if (flags & TCL_TRACE_UNSETS) {
TclDStringAppendLiteral(&cmd, " unset");
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
}
#endif
/*
* Execute the command. We discard any object result the command
|
| ︙ | ︙ | |||
2573 2574 2575 2576 2577 2578 2579 |
} while (*p != '\0');
p--;
if (*p == ')') {
int offset = (openParen - part1);
char *newPart1;
Tcl_DStringInit(&nameCopy);
| | | 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 |
} while (*p != '\0');
p--;
if (*p == ')') {
int offset = (openParen - part1);
char *newPart1;
Tcl_DStringInit(&nameCopy);
Tcl_DStringAppend(&nameCopy, part1, p-part1);
newPart1 = Tcl_DStringValue(&nameCopy);
newPart1[offset] = 0;
part1 = newPart1;
part2 = newPart1 + offset + 1;
copiedName = 1;
}
break;
|
| ︙ | ︙ | |||
2711 2712 2713 2714 2715 2716 2717 |
type = "array";
break;
}
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
} else {
| | > | 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 |
type = "array";
break;
}
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
} else {
Tcl_SetObjResult((Tcl_Interp *)iPtr,
Tcl_NewStringObj(result, -1));
}
Tcl_AddErrorInfo((Tcl_Interp *)iPtr, "");
Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf(
"\n (%s trace on \"%s%s%s%s\")", type, part1,
(part2 ? "(" : ""), (part2 ? part2 : ""),
(part2 ? ")" : "") ));
|
| ︙ | ︙ |
Changes to generic/tclUniData.c.
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3,
16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17,
17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18,
18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
| | | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 |
3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3,
16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17,
17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18,
18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86,
86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100,
21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100,
100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100,
100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21,
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) {
return isspace(UCHAR(ch)); /* INTL: ISO space */
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
}
}
/*
*----------------------------------------------------------------------
| > > > | 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) {
return isspace(UCHAR(ch)); /* INTL: ISO space */
} else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b
|| (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
*/
static ProcessGlobalValue executableName = {
0, 0, NULL, NULL, NULL, NULL, NULL
};
/*
| | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
*/
static ProcessGlobalValue executableName = {
0, 0, NULL, NULL, NULL, NULL, NULL
};
/*
* The following values are used in the flags arguments of Tcl*Scan*Element
* and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and
* TCL_DONT_QUOTE_HASH are defined in tcl.h, like so:
*
#define TCL_DONT_USE_BRACES 1
#define TCL_DONT_QUOTE_HASH 8
*
* Those are public flag bits which callers of the public routines
* Tcl_Convert*Element() can use to indicate:
*
|
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | * are for internal use only. Make sure they do not overlap with the public * values above. * * The Tcl*Scan*Element() routines make a determination which of 4 modes of * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * | | | | | | | | | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | * are for internal use only. Make sure they do not overlap with the public * values above. * * The Tcl*Scan*Element() routines make a determination which of 4 modes of * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * * CONVERT_NONE The element needs no quoting. Its literal string is * suitable as is. * CONVERT_BRACE The conversion should be enclosing the literal string * in braces. * CONVERT_ESCAPE The conversion should be using backslashes to escape * any characters in the string that require it. * CONVERT_MASK A mask value used to extract the conversion mode from * the flags argument. * Also indicates a strange conversion mode where all * special characters are escaped with backslashes * *except for braces*. This is a strange and unnecessary * case, but it's part of the historical way in which * lists have been formatted in Tcl. To experiment with * removing this case, set the value of COMPAT to 0. * * One last flag value is used only by callers of TclScanElement(). The flag * value produced by a call to Tcl*Scan*Element() will never leave this bit * set. * * CONVERT_ANY The caller of TclScanElement() declares it can make no * promise about what public flags will be passed to the * matching call of TclConvertElement(). As such, * TclScanElement() has to determine the worst case * destination buffer length over all possibilities, and * in other cases this means an overestimate of the * required size. * * For more details, see the comments on the Tcl*Scan*Element and * Tcl*Convert*Element routines. |
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
UpdateStringOfEndOffset, /* updateStringProc */
SetEndOffsetFromAny
};
/*
* * STRING REPRESENTATION OF LISTS * * *
*
| | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > > | > > > | > > > > | > > | > > | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
UpdateStringOfEndOffset, /* updateStringProc */
SetEndOffsetFromAny
};
/*
* * STRING REPRESENTATION OF LISTS * * *
*
* The next several routines implement the conversions of strings to and from
* Tcl lists. To understand their operation, the rules of parsing and
* generating the string representation of lists must be known. Here we
* describe them in one place.
*
* A list is made up of zero or more elements. Any string is a list if it is
* made up of alternating substrings of element-separating ASCII whitespace
* and properly formatted elements.
*
* The ASCII characters which can make up the whitespace between list elements
* are:
*
* \u0009 \t TAB
* \u000A \n NEWLINE
* \u000B \v VERTICAL TAB
* \u000C \f FORM FEED
* \u000D \r CARRIAGE RETURN
* \u0020 SPACE
*
* NOTE: differences between this and other places where Tcl defines a role
* for "whitespace".
*
* * Unlike command parsing, here NEWLINE is just another whitespace
* character; its role as a command terminator in a script has no
* importance here.
*
* * Unlike command parsing, the BACKSLASH NEWLINE sequence is not
* considered to be a whitespace character.
*
* * Other Unicode whitespace characters (recognized by [string is space]
* or Tcl_UniCharIsSpace()) do not play any role as element separators
* in Tcl lists.
*
* * The NUL byte ought not appear, as it is not in strings properly
* encoded for Tcl, but if it is present, it is not treated as
* separating whitespace, or a string terminator. It is just another
* character in a list element.
*
* The interpretation of a formatted substring as a list element follows rules
* similar to the parsing of the words of a command in a Tcl script. Backslash
* substitution plays a key role, and is defined exactly as it is in command
* parsing. The same routine, TclParseBackslash() is used in both command
* parsing and list parsing.
*
* NOTE: This means that if and when backslash substitution rules ever change
* for command parsing, the interpretation of strings as lists also changes.
*
* Backslash substitution replaces an "escape sequence" of one or more
* characters starting with
* \u005c \ BACKSLASH
* with a single character. The one character escape sequence case happens only
* when BACKSLASH is the last character in the string. In all other cases, the
* escape sequence is at least two characters long.
*
* The formatted substrings are interpreted as element values according to the
* following cases:
*
* * If the first character of a formatted substring is
* \u007b { OPEN BRACE
* then the end of the substring is the matching
* \u007d } CLOSE BRACE
* character, where matching is determined by counting nesting levels, and
* not including any brace characters that are contained within a backslash
* escape sequence in the nesting count. Having found the matching brace,
* all characters between the braces are the string value of the element.
* If no matching close brace is found before the end of the string, the
* string is not a Tcl list. If the character following the close brace is
* not an element separating whitespace character, or the end of the string,
* then the string is not a Tcl list.
*
* NOTE: this differs from a brace-quoted word in the parsing of a Tcl
* command only in its treatment of the backslash-newline sequence. In a
* list element, the literal characters in the backslash-newline sequence
* become part of the element value. In a script word, conversion to a
* single SPACE character is done.
*
* NOTE: Most list element values can be represented by a formatted
* substring using brace quoting. The exceptions are any element value that
* includes an unbalanced brace not in a backslash escape sequence, and any
* value that ends with a backslash not itself in a backslash escape
* sequence.
*
* * If the first character of a formatted substring is
* \u0022 " QUOTE
* then the end of the substring is the next QUOTE character, not counting
* any QUOTE characters that are contained within a backslash escape
* sequence. If no next QUOTE is found before the end of the string, the
* string is not a Tcl list. If the character following the closing QUOTE is
* not an element separating whitespace character, or the end of the string,
* then the string is not a Tcl list. Having found the limits of the
* substring, the element value is produced by performing backslash
* substitution on the character sequence between the open and close QUOTEs.
*
* NOTE: Any element value can be represented by this style of formatting,
* given suitable choice of backslash escape sequences.
*
* * All other formatted substrings are terminated by the next element
* separating whitespace character in the string. Having found the limits
* of the substring, the element value is produced by performing backslash
* substitution on it.
*
* NOTE: Any element value can be represented by this style of formatting,
* given suitable choice of backslash escape sequences, with one exception.
* The empty string cannot be represented as a list element without the use
* of either braces or quotes to delimit it.
*
* This collection of parsing rules is implemented in the routine
* TclFindElement().
*
* In order to produce lists that can be parsed by these rules, we need the
* ability to distinguish between characters that are part of a list element
* value from characters providing syntax that define the structure of the
* list. This means that our code that generates lists must at a minimum be
* able to produce escape sequences for the 10 characters identified above
* that have significance to a list parser.
*
* * * CANONICAL LISTS * * * * *
*
* In addition to the basic rules for parsing strings into Tcl lists, there
* are additional properties to be met by the set of list values that are
* generated by Tcl. Such list values are often said to be in "canonical
* form":
*
* * When any canonical list is evaluated as a Tcl script, it is a script of
* either zero commands (an empty list) or exactly one command. The command
* word is exactly the first element of the list, and each argument word is
* exactly one of the following elements of the list. This means that any
* characters that have special meaning during script evaluation need
* special treatment when canonical lists are produced:
*
* * Whitespace between elements may not include NEWLINE.
* * The command terminating character,
* \u003b ; SEMICOLON
* must be BRACEd, QUOTEd, or escaped so that it does not terminate the
* command prematurely.
* * Any of the characters that begin substitutions in scripts,
* \u0024 $ DOLLAR
* \u005b [ OPEN BRACKET
* \u005c \ BACKSLASH
* need to be BRACEd or escaped.
* * In any list where the first character of the first element is
* \u0023 # HASH
* that HASH character must be BRACEd, QUOTEd, or escaped so that it
* does not convert the command into a comment.
* * Any list element that contains the character sequence BACKSLASH
* NEWLINE cannot be formatted with BRACEs. The BACKSLASH character
* must be represented by an escape sequence, and unless QUOTEs are
* used, the NEWLINE must be as well.
*
* * It is also guaranteed that one can use a canonical list as a building
* block of a larger script within command substitution, as in this example:
* set script "puts \[[list $cmd $arg]]"; eval $script
* To support this usage, any appearance of the character
* \u005d ] CLOSE BRACKET
* in a list element must be BRACEd, QUOTEd, or escaped.
*
* * Finally it is guaranteed that enclosing a canonical list in braces
* produces a new value that is also a canonical list. This new list has
* length 1, and its only element is the original canonical list. This same
* guarantee also makes it possible to construct scripts where an argument
* word is given a list value by enclosing the canonical form of that list
* in braces:
* set script "puts {[list $one $two $three]}"; eval $script
* This sort of coding was once fairly common, though it's become more
* idiomatic to see the following instead:
* set script [list puts [list $one $two $three]]; eval $script
* In order to support this guarantee, every canonical list must have
* balance when counting those braces that are not in escape sequences.
*
* Within these constraints, the canonical list generation routines
* TclScanElement() and TclConvertElement() attempt to generate the string for
* any list that is easiest to read. When an element value is itself
* acceptable as the formatted substring, it is usually used (CONVERT_NONE).
* When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is
* usually preferred over the use of escape sequences (CONVERT_ESCAPE). There
* are some exceptions to both of these preferences for reasons of code
* simplicity, efficiency, and continuation of historical habits. Canonical
* lists never use the QUOTE formatting to delimit their elements because that
* form of quoting does not nest, which makes construction of nested lists far
* too much trouble. Canonical lists always use only a single SPACE character
* for element-separating whitespace.
*
* * * FUTURE CONSIDERATIONS * * *
*
* When a list element requires quoting or escaping due to a CLOSE BRACKET
* character or an internal QUOTE character, a strange formatting mode is
* recommended. For example, if the value "a{b]c}d" is converted by the usual
* modes:
*
* CONVERT_BRACE: a{b]c}d => {a{b]c}d}
* CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d
*
* we get perfectly usable formatted list elements. However, this is not what
* Tcl releases have been producing. Instead, we have:
*
* CONVERT_MASK: a{b]c}d => a{b\]c}d
*
* where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect
* can be seen replacing ] with " in this example. There does not appear to be
* any functional or aesthetic purpose for this strange additional mode. The
* sole purpose I can see for preserving it is to keep generating the same
* formatted lists programmers have become accustomed to, and perhaps written
* tests to expect. That is, compatibility only. The additional code
* complexity required to support this mode is significant. The lines of code
* supporting it are delimited in the routines below with #if COMPAT
* directives. This makes it easy to experiment with eliminating this
* formatting mode simply with "#define COMPAT 0" above. I believe this is
* worth considering.
*
* Another consideration is the treatment of QUOTE characters in list
* elements. TclConvertElement() must have the ability to produce the escape
* sequence \" so that when a list element begins with a QUOTE we do not
* confuse that first character with a QUOTE used as list syntax to define
* list structure. However, that is the only place where QUOTE characters need
* quoting. In this way, handling QUOTE could really be much more like the way
* we handle HASH which also needs quoting and escaping only in particular
* situations. Following up this could increase the set of list elements that
* can use the CONVERT_NONE formatting mode.
*
* More speculative is that the demands of canonical list form require brace
* balance for the list as a whole, while the current implementation achieves
* this by establishing brace balance for every element.
*
* Finally, a reminder that the rules for parsing and formatting lists are
* closely tied together with the rules for parsing and evaluating scripts,
* and will need to evolve in sync.
*/
/*
*----------------------------------------------------------------------
*
* TclMaxListLength --
*
* Given 'bytes' pointing to 'numBytes' bytes, scan through them and
* count the number of whitespace runs that could be list element
* separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a
* full list parser. Typically used to get a quick and dirty overestimate
* of length size in order to allocate space for an actual list parser to
* operate with.
*
* Results:
* Returns the largest number of list elements that could possibly be in
* this string, interpreted as a Tcl list. If 'endPtr' is not NULL,
* writes a pointer to the end of the string scanned there.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclMaxListLength(
const char *bytes,
int numBytes,
const char **endPtr)
{
int count = 0;
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
/*
* No list element before leading white space.
*/
count += 1 - TclIsSpaceProc(*bytes);
/*
* Count white space runs as potential element separators.
*/
while (numBytes) {
if ((numBytes == -1) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProc(*bytes)) {
/*
* Space run started; bump count.
*/
count++;
do {
bytes++;
numBytes -= (numBytes != -1);
} while (numBytes && TclIsSpaceProc(*bytes));
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
break;
}
/*
* (*bytes) is non-space; return to counting state.
*/
}
bytes++;
numBytes -= (numBytes != -1);
}
/*
* No list element following trailing white space.
*/
count -= TclIsSpaceProc(bytes[-1]);
done:
if (endPtr) {
*endPtr = bytes;
}
return count;
}
/*
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 | * * If TCL_OK is returned, then *elementPtr will be set to point to the * first element of list, and *nextPtr will be set to point to the * character just after any white space following the last character * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, | | | | | | | | | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 | * * If TCL_OK is returned, then *elementPtr will be set to point to the * first element of list, and *nextPtr will be set to point to the * character just after any white space following the last character * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, * *sizePtr is filled in with the number of bytes in the element. If the * element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, * and both *elementPtr and *nextPtr will point just after the last * character in the list. If literalPtr is non-NULL, *literalPtr is set * to a boolean value indicating whether the substring returned as the * values of **elementPtr and *sizePtr is the literal value of a list * element. If not, a call to TclCopyAndCollapse() is needed to produce * the actual value of the list element. Note: this function does NOT * collapse backslash sequences, but uses *literalPtr to tell callers * when it is required for them to do so. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
583 584 585 586 587 588 589 |
*/
case '\\':
if (openBraces == 0) {
/*
* A backslash sequence not within a brace quoted element
* means the value of the element is different from the
| | | > | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
*/
case '\\':
if (openBraces == 0) {
/*
* A backslash sequence not within a brace quoted element
* means the value of the element is different from the
* substring we are parsing. A call to TclCopyAndCollapse() is
* needed to produce the element value. Inform the caller.
*/
literal = 0;
}
TclParseBackslash(p, limit - p, &numChars, NULL);
p += (numChars - 1);
break;
/*
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
/*
* End of list: terminate element.
*/
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
| > | < > | < | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
/*
* End of list: terminate element.
*/
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched open brace in list", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched open quote in list", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
NULL);
}
return TCL_ERROR;
}
size = (p - elemStart);
}
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 | * * TclCopyAndCollapse -- * * Copy a string and substitute all backslash escape sequences * * Results: * Count bytes get copied from src to dst. Along the way, backslash | | | | > | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
*
* TclCopyAndCollapse --
*
* Copy a string and substitute all backslash escape sequences
*
* Results:
* Count bytes get copied from src to dst. Along the way, backslash
* sequences are substituted in the copy. After scanning count bytes from
* src, a null character is placed at the end of dst. Returns the number
* of bytes that got written to dst.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCopyAndCollapse(
int count, /* Number of byte to copy from src. */
const char *src, /* Copy from here... */
char *dst) /* ... to here. */
{
int newCount = 0;
while (count > 0) {
char c = *src;
if (c == '\\') {
int numRead;
int backslashCount = TclParseBackslash(src, count, &numRead, dst);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 |
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
int length, size, i, result, elSize;
/*
| | | | | < | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
int length, size, i, result, elSize;
/*
* Allocate enough space to work in. A (const char *) for each (possible)
* list element plus one more for terminating NULL, plus as many bytes as
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
length = end - list;
argv = ckalloc((size * sizeof(char *)) + length + 1);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 |
}
if (*element == 0) {
break;
}
if (i >= size) {
ckfree(argv);
if (interp != NULL) {
| > | < | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 |
}
if (*element == 0) {
break;
}
if (i >= size) {
ckfree(argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
return TCL_ERROR;
}
argv[i] = p;
if (literal) {
|
| ︙ | ︙ | |||
840 841 842 843 844 845 846 | * Tcl_ScanElement -- * * This function is a companion function to Tcl_ConvertElement. It scans * a string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. * * Results: | | | | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 | * Tcl_ScanElement -- * * This function is a companion function to Tcl_ConvertElement. It scans * a string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. * * Results: * The return value is an overestimate of the number of bytes that will * be needed by Tcl_ConvertElement to produce a valid list element from * src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
872 873 874 875 876 877 878 | * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl * list element. If length is -1, then the string is scanned from src up * to the first null byte. * * Results: | | | | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 | * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl * list element. If length is -1, then the string is scanned from src up * to the first null byte. * * Results: * The return value is an overestimate of the number of bytes that will * be needed by Tcl_ConvertCountedElement to produce a valid list element * from src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
902 903 904 905 906 907 908 | } /* *---------------------------------------------------------------------- * * TclScanElement -- * | | | | | | | | | | | | | | | | > | > > > | | | > | > > | | > | > > > > | > > | | > | > > > | > > | | > > > | > > | | | | | > > | > > | | | | < > > > | > > > | > > > | > > > | > > > | > > | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 |
}
/*
*----------------------------------------------------------------------
*
* TclScanElement --
*
* This function is a companion function to TclConvertElement. It scans a
* string to see what needs to be done to it (e.g. add backslashes or
* enclosing braces) to make the string into a valid Tcl list element. If
* length is -1, then the string is scanned from src up to the first null
* byte. A NULL value for src is treated as an empty string. The incoming
* value of *flagPtr is a report from the caller what additional flags it
* will pass to TclConvertElement().
*
* Results:
* The recommended formatting mode for the element is determined and a
* value is written to *flagPtr indicating that recommendation. This
* recommendation is combined with the incoming flag values in *flagPtr
* set by the caller to determine how many bytes will be needed by
* TclConvertElement() in which to write the formatted element following
* the recommendation modified by the flag values. This number of bytes
* is the return value of the routine. In some situations it may be an
* overestimate, but so long as the caller passes the same flags to
* TclConvertElement(), it will be large enough.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
* needs protection or escape. */
int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some
* reason bare or brace-quoted form fails. */
int extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
int bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
int preferBrace = 0; /* CONVERT_MASK mode. */
int braceCount = 0; /* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
/*
* Empty string element must be brace quoted.
*/
*flagPtr = CONVERT_BRACE;
return 2;
}
if ((*p == '{') || (*p == '"')) {
/*
* Must escape or protect so leading character of value is not
* misinterpreted as list element delimiting syntax.
*/
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
}
while (length) {
if (CHAR_TYPE(*p) != TYPE_NORMAL) {
switch (*p) {
case '{': /* TYPE_BRACE */
#if COMPAT
braceCount++;
#endif /* COMPAT */
extra++; /* Escape '{' => '\{' */
nestingLevel++;
break;
case '}': /* TYPE_BRACE */
#if COMPAT
braceCount++;
#endif /* COMPAT */
extra++; /* Escape '}' => '\}' */
nestingLevel--;
if (nestingLevel < 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
requireEscape = 1;
}
break;
case ']': /* TYPE_CLOSE_BRACK */
case '"': /* TYPE_SPACE */
#if COMPAT
forbidNone = 1;
extra++; /* Escapes all just prepend a backslash */
preferEscape = 1;
break;
#else
/* FLOW THROUGH */
#endif /* COMPAT */
case '[': /* TYPE_SUBS */
case '$': /* TYPE_SUBS */
case ';': /* TYPE_COMMAND_END */
case ' ': /* TYPE_SPACE */
case '\f': /* TYPE_SPACE */
case '\n': /* TYPE_COMMAND_END */
case '\r': /* TYPE_SPACE */
case '\t': /* TYPE_SPACE */
case '\v': /* TYPE_SPACE */
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
requireEscape = 1;
break;
}
if (p[1] == '\n') {
extra++; /* Escape newline => '\n', one byte longer */
/*
* Backslash newline sequence. Brace quoting not permitted.
*/
requireEscape = 1;
length -= (length > 0);
p++;
break;
}
if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
extra++; /* Escape sequences all one byte longer. */
length -= (length > 0);
p++;
}
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == -1) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
}
}
length -= (length > 0);
p++;
}
endOfString:
if (nestingLevel != 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
requireEscape = 1;
}
/*
* We need at least as many bytes as are in the element value...
*/
bytesNeeded = p - src;
if (requireEscape) {
/*
* We must use escape sequences. Add all the extra bytes needed to
* have room to create them.
*/
bytesNeeded += extra;
/*
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
goto overflowCheck;
}
if (*flagPtr & CONVERT_ANY) {
/*
* The caller has not let us know what flags it will pass to
* TclConvertElement() so compute the max size we might need for any
* possible choice. Normally the formatting using escape sequences is
* the longer one, and a minimum "extra" value of 2 makes sure we
* don't request too small a buffer in those edge cases where that's
* not true.
*/
if (extra < 2) {
extra = 2;
}
*flagPtr &= ~CONVERT_ANY;
*flagPtr |= TCL_DONT_USE_BRACES;
}
if (forbidNone) {
/*
* We must request some form of quoting of escaping...
*/
#if COMPAT
if (preferEscape && !preferBrace) {
/*
* If we are quoting solely due to ] or internal " characters use
* the CONVERT_MASK mode where we escape all special characters
* except for braces. "extra" counted space needed to escape
* braces too, so substract "braceCount" to get our actual needs.
*/
bytesNeeded += (extra - braceCount);
/* Make room to escape leading #, if needed. */
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
/*
* If the caller reports it will direct TclConvertElement() to
* use full escapes on the element, add back the bytes needed to
* escape the braces.
*/
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
goto overflowCheck;
}
#endif /* COMPAT */
if (*flagPtr & TCL_DONT_USE_BRACES) {
/*
* If the caller reports it will direct TclConvertElement() to
* use escapes, add the extra bytes needed to have room for them.
*/
bytesNeeded += extra;
/*
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
} else {
/*
* Add 2 bytes for room for the enclosing braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_BRACE;
goto overflowCheck;
}
/*
* So far, no need to quote or escape anything.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
/*
* If we need to quote a leading #, make room to enclose in braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_NONE;
overflowCheck:
if (bytesNeeded < 0) {
Tcl_Panic("TclScanElement: string length overflow");
}
return bytesNeeded;
}
/*
|
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 | } /* *---------------------------------------------------------------------- * * TclConvertElement -- * | | | | > | > | > > > | > > | > | > > > | > > > | > > > | > > | | > < < | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 |
}
/*
*----------------------------------------------------------------------
*
* TclConvertElement --
*
* This is a companion function to TclScanElement. Given the information
* produced by TclScanElement, this function converts a string to a list
* element equal to that string.
*
* Results:
* Information is copied to *dst in the form of a list element identical
* to src (i.e. if Tcl_SplitList is applied to dst it will produce a
* string identical to src). The return value is a count of the number of
* characters copied (not including the terminating NULL character).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclConvertElement(
register const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int conversion = flags & CONVERT_MASK;
char *p = dst;
/*
* Let the caller demand we use escape sequences rather than braces.
*/
if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
src = tclEmptyStringRep;
length = 0;
conversion = CONVERT_BRACE;
}
/*
* Escape leading hash as needed and requested.
*/
if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
if (conversion == CONVERT_ESCAPE) {
p[0] = '\\';
p[1] = '#';
p += 2;
src++;
length -= (length > 0);
} else {
conversion = CONVERT_BRACE;
}
}
/*
* No escape or quoting needed. Copy the literal string value.
*/
if (conversion == CONVERT_NONE) {
if (length == -1) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
return p - dst;
} else {
memcpy(dst, src, length);
return length;
}
}
/*
* Formatted string is original string enclosed in braces.
*/
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
if (length == -1) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
} else {
memcpy(p, src, length);
p += length;
}
*p = '}';
p++;
return p - dst;
}
/* conversion == CONVERT_ESCAPE or CONVERT_MASK */
/*
* Formatted string is original string converted to escape sequences.
*/
for ( ; length; src++, length -= (length > 0)) {
switch (*src) {
case ']':
case '[':
case '$':
case ';':
case ' ':
case '\\':
case '"':
*p = '\\';
p++;
break;
case '{':
case '}':
#if COMPAT
if (conversion == CONVERT_ESCAPE)
#endif /* COMPAT */
{
*p = '\\';
p++;
}
break;
case '\f':
*p = '\\';
p++;
*p = 'f';
p++;
continue;
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 1365 |
*p = 'v';
p++;
continue;
case '\0':
if (length == -1) {
return p - dst;
}
/*
| > | | | | | > | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
*p = 'v';
p++;
continue;
case '\0':
if (length == -1) {
return p - dst;
}
/*
* If we reach this point, there's an embedded NULL in the string
* range being processed, which should not happen when the
* encoding rules for Tcl strings are properly followed. If the
* day ever comes when we stop tolerating such things, this is
* where to put the Tcl_Panic().
*/
break;
}
*p = *src;
p++;
}
return p - dst;
}
|
| ︙ | ︙ | |||
1398 1399 1400 1401 1402 1403 1404 |
*/
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
| | < | | | | > > | | | | | | < | | | > | 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 |
*/
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i, bytesNeeded = 0;
char *result, *dst;
const int maxFlags = UINT_MAX / sizeof(int);
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
if (argc == 0) {
result = ckalloc(1);
result[0] = '\0';
return result;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else if (argc > maxFlags) {
/*
* We cannot allocate a large enough flag array to format this list in
* one pass. We could imagine converting this routine to a multi-pass
* implementation, but for sizeof(int) == 4, the limit is a max of
* 2^30 list elements and since each element is at least one byte
* formatted, and requires one byte space between it and the next one,
* that a minimum space requirement of 2^31 bytes, which is already
* INT_MAX. If we tried to format a list of > maxFlags elements, we're
* just going to overflow the size limits on the formatted string
* anyway, so just issue that same panic early.
*/
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
} else {
flagPtr = ckalloc(argc * sizeof(int));
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
|
| ︙ | ︙ | |||
1507 1508 1509 1510 1511 1512 1513 |
return (char) ch;
}
/*
*----------------------------------------------------------------------
*
* TclTrimRight --
| > | | | | | | | > | > > > | > > > | > > > | > > > | | | | | | | > | > > > | > > > | > > > | > > | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 |
return (char) ch;
}
/*
*----------------------------------------------------------------------
*
* TclTrimRight --
*
* Takes two counted strings in the Tcl encoding which must both be null
* terminated. Conceptually trims from the right side of the first string
* all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimRight(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
{
const char *p = bytes + numBytes;
int pInc;
if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
Tcl_Panic("TclTrimRight works only on null-terminated strings");
}
/*
* Empty strings -> nothing to do.
*/
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
Tcl_UniChar ch1;
const char *q = trim;
int bytesLeft = numTrim;
p = Tcl_UtfPrev(p, bytes);
pInc = TclUtfToUniChar(p, &ch1);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
Tcl_UniChar ch2;
int qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is last non-trimmed char.
*/
p += pInc;
break;
}
} while (p > bytes);
return numBytes - (p - bytes);
}
/*
*----------------------------------------------------------------------
*
* TclTrimLeft --
*
* Takes two counted strings in the Tcl encoding which must both be null
* terminated. Conceptually trims from the left side of the first string
* all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
{
const char *p = bytes;
if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
Tcl_Panic("TclTrimLeft works only on null-terminated strings");
}
/*
* Empty strings -> nothing to do.
*/
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
Tcl_UniChar ch1;
int pInc = TclUtfToUniChar(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
Tcl_UniChar ch2;
int qInc = TclUtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is first non-trimmed char.
*/
break;
}
p += pInc;
numBytes -= pInc;
} while (numBytes);
|
| ︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 |
Tcl_Concat(
int argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
int i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
| > | > > > | > > | | > > > | > > | > | > > | | > | > > > | > > | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
Tcl_Concat(
int argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
int i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
* Dispose of the empty result corner case first to simplify later code.
*/
if (argc == 0) {
result = (char *) ckalloc(1);
result[0] = '\0';
return result;
}
/*
* First allocate the result buffer at the size required.
*/
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
if (bytesNeeded < 0) {
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
}
if (bytesNeeded + argc - 1 < 0) {
/*
* Panic test could be tighter, but not going to bother for this
* legacy routine.
*/
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
result = ckalloc((unsigned) (bytesNeeded + argc));
for (p = result, i = 0; i < argc; i++) {
int trim, elemLength;
const char *element;
element = argv[i];
elemLength = strlen(argv[i]);
/*
* Trim away the leading whitespace.
*/
trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
element += trim;
elemLength -= trim;
/*
* Trim away the trailing whitespace. Do not permit trimming to expose
* a final backslash character.
*/
trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
trim -= trim && (element[elemLength - trim - 1] == '\\');
elemLength -= trim;
/*
* If we're left with empty element after trimming, do nothing.
*/
if (elemLength == 0) {
continue;
}
/*
* Append to the result with space if needed.
*/
if (needSpace) {
*p++ = ' ';
}
memcpy(p, element, (size_t) elemLength);
p += elemLength;
needSpace = 1;
}
|
| ︙ | ︙ | |||
1798 1799 1800 1801 1802 1803 1804 1805 1806 |
}
return resPtr;
}
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*/
| > > < > | | | > > | > > | | > | > > > | > > | 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 |
}
return resPtr;
}
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*
* First try to pre-allocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
if (bytesNeeded < 0) {
break;
}
}
/*
* Does not matter if this fails, will simply try later to build up the
* string with each Append reallocating as needed with the usual string
* append algorithm. When that fails it will report the error.
*/
TclNewObj(resPtr);
Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
int trim;
element = TclGetStringFromObj(objv[i], &elemLength);
/*
* Trim away the leading whitespace.
*/
trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
element += trim;
elemLength -= trim;
/*
* Trim away the trailing whitespace. Do not permit trimming to expose
* a final backslash character.
*/
trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE);
trim -= trim && (element[elemLength - trim - 1] == '\\');
elemLength -= trim;
/*
* If we're left with empty element after trimming, do nothing.
*/
if (elemLength == 0) {
continue;
}
/*
* Append to the result with space if needed.
*/
if (needSpace) {
Tcl_AppendToObj(resPtr, " ", 1);
}
Tcl_AppendToObj(resPtr, element, elemLength);
needSpace = 1;
}
return resPtr;
|
| ︙ | ︙ | |||
2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 |
endChar = *pattern;
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
while (*pattern != ']') {
| > | 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 |
endChar = *pattern;
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
while (*pattern != ']') {
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 | } /* *---------------------------------------------------------------------- * * TclStringMatchObj -- * | | | | | 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 | } /* *---------------------------------------------------------------------- * * TclStringMatchObj -- * * See if a particular string matches a particular pattern. Allows case * insensitivity. This is the generic multi-type handler for the various * matching algorithms. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The * matching operation permits the following special characters in the * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: |
| ︙ | ︙ | |||
2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 |
*/
memcpy(dsPtr->string + dsPtr->length, bytes, length);
dsPtr->length += length;
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringAppendElement --
*
* Append a list element to the current value of a dynamic string.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 |
*/
memcpy(dsPtr->string + dsPtr->length, bytes, length);
dsPtr->length += length;
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* TclDStringAppendObj, TclDStringAppendDString --
*
* Simple wrappers round Tcl_DStringAppend that make it easier to append
* from particular sources of strings.
*
*----------------------------------------------------------------------
*/
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
int length;
char *bytes = Tcl_GetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
char *
TclDStringAppendDString(
Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr)
{
return Tcl_DStringAppend(dsPtr, Tcl_DStringValue(toAppendPtr),
Tcl_DStringLength(toAppendPtr));
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringAppendElement --
*
* Append a list element to the current value of a dynamic string.
|
| ︙ | ︙ | |||
2622 2623 2624 2625 2626 2627 2628 |
void
Tcl_DStringResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
| < < | < < < < < < < < < < < < < < | 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 |
void
Tcl_DStringResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringGetResult --
*
|
| ︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 |
* of interp. */
{
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 |
* of interp. */
{
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
/*
* Do more efficient transfer when we know the result is a Tcl_Obj. When
* there's no st`ring result, we only have to deal with two cases:
*
* 1. When the string rep is the empty string, when we don't copy but
* instead use the staticSpace in the DString to hold an empty string.
* 2. When the string rep is not there or there's a real string rep, when
* we use Tcl_GetString to fetch (or generate) the string rep - which
* we know to have been allocated with ckalloc() - and use it to
* populate the DString space. Then, we free the internal rep. and set
* the object's string representation back to the canonical empty
* string.
*/
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = Tcl_GetString(iPtr->objResultPtr);
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
TclFreeIntRep(iPtr->objResultPtr);
iPtr->objResultPtr->bytes = tclEmptyStringRep;
iPtr->objResultPtr->length = 0;
}
return;
}
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 |
Tcl_Obj *
TclDStringToObj(
Tcl_DString *dsPtr)
{
Tcl_Obj *result;
| > | | | | | | | | > | 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 |
Tcl_Obj *
TclDStringToObj(
Tcl_DString *dsPtr)
{
Tcl_Obj *result;
if (dsPtr->string == dsPtr->staticSpace) {
if (dsPtr->length == 0) {
TclNewObj(result);
} else {
/*
* Static buffer, so must copy.
*/
TclNewStringObj(result, dsPtr->string, dsPtr->length);
}
} else {
/*
* Dynamic buffer, so transfer ownership and reset.
*/
TclNewObj(result);
result->bytes = dsPtr->string;
|
| ︙ | ︙ | |||
2789 2790 2791 2792 2793 2794 2795 |
*/
void
Tcl_DStringStartSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
| | | | 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 |
*/
void
Tcl_DStringStartSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
TclDStringAppendLiteral(dsPtr, " {");
} else {
TclDStringAppendLiteral(dsPtr, "{");
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringEndSublist --
|
| ︙ | ︙ | |||
2817 2818 2819 2820 2821 2822 2823 |
*----------------------------------------------------------------------
*/
void
Tcl_DStringEndSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
| | | 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 |
*----------------------------------------------------------------------
*/
void
Tcl_DStringEndSublist(
Tcl_DString *dsPtr) /* Dynamic string. */
{
TclDStringAppendLiteral(dsPtr, "}");
}
/*
*----------------------------------------------------------------------
*
* Tcl_PrintDouble --
*
|
| ︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 | * the given number, choose the shortest, breaking ties in favour of * the nearest, breaking remaining ties in favour of the one ending in * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: * | | | | | | | | | | 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 |
* the given number, choose the shortest, breaking ties in favour of
* the nearest, breaking remaining ties in favour of the one ending in
* an even digit."
*
* Tcl 8.4 implements the first of these, which gives rise to
* anomalies in formatting:
*
* % expr 0.1
* 0.10000000000000001
* % expr 0.01
* 0.01
* % expr 1e-7
* 9.9999999999999995e-08
*
* For human readability, it appears better to choose the second rule,
* and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
* 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
* 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 */,
&exponent, &signum, &end);
}
if (signum) {
*dst++ = '-';
}
p = digits;
if (exponent < -4 || exponent > 16) {
/*
|
| ︙ | ︙ | |||
3187 3188 3189 3190 3191 3192 3193 | * The formatted characters are written into the storage pointer to by * the "buffer" argument. * *---------------------------------------------------------------------- */ int | | | | | | | | 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 |
* The formatted characters are written into the storage pointer to by
* the "buffer" argument.
*
*----------------------------------------------------------------------
*/
int
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
long n) /* The integer to format. */
{
long intVal;
int i;
int numFormatted, j;
const char *digits = "0123456789";
/*
* Check first whether "n" is zero.
*/
if (n == 0) {
buffer[0] = '0';
buffer[1] = 0;
return 1;
}
/*
* Check whether "n" is the maximum negative value. This is -2^(m-1) for
* an m-bit word, and has no positive equivalent; negating it produces the
* same value.
*/
intVal = -n; /* [Bug 3390638] Workaround for*/
if (n == -n || intVal == n) { /* broken compiler optimizers. */
return sprintf(buffer, "%ld", n);
}
|
| ︙ | ︙ | |||
3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 |
/*
* Now reverse the characters.
*/
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
buffer[i] = buffer[j];
buffer[j] = tmp;
}
return numFormatted;
}
/*
| > | 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 |
/*
* Now reverse the characters.
*/
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
buffer[i] = buffer[j];
buffer[j] = tmp;
}
return numFormatted;
}
/*
|
| ︙ | ︙ | |||
3347 3348 3349 3350 3351 3352 3353 |
/*
* Report a parse error.
*/
parseError:
if (interp != NULL) {
| < < < < < < | | | | 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 |
/*
* Report a parse error.
*/
parseError:
if (interp != NULL) {
bytes = Tcl_GetString(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);
}
|
| ︙ | ︙ | |||
3391 3392 3393 3394 3395 3396 3397 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
| | | | 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
char buffer[TCL_INTEGER_SPACE + 5];
register int len;
memcpy(buffer, "end", 4);
len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
}
objPtr->bytes = ckalloc((unsigned) len+1);
memcpy(objPtr->bytes, buffer, (unsigned) len+1);
|
| ︙ | ︙ | |||
3448 3449 3450 3451 3452 3453 3454 |
* Check for a string rep of the right form.
*/
bytes = TclGetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
| | < | | 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 |
* Check for a string rep of the right form.
*/
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;
}
/*
* Convert the string rep.
|
| ︙ | ︙ | |||
3484 3485 3486 3487 3488 3489 3490 |
} else {
/*
* Conversion failed. Report the error.
*/
badIndexFormat:
if (interp != NULL) {
| | < | | 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 |
} else {
/*
* Conversion failed. Report the error.
*/
badIndexFormat:
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;
}
/*
* The conversion succeeded. Free the old internal rep and set the new
|
| ︙ | ︙ | |||
3562 3563 3564 3565 3566 3567 3568 |
if (interp != NULL) {
/*
* Don't reset the result here because we want this result to
* be added to an existing error message as extra info.
*/
| > | < | 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 |
if (interp != NULL) {
/*
* Don't reset the result here because we want this result to
* be added to an existing error message as extra info.
*/
Tcl_AppendToObj(Tcl_GetObjResult(interp),
" (looks like invalid octal number)", -1);
}
return 1;
}
}
return 0;
}
|
| ︙ | ︙ | |||
3715 3716 3717 3718 3719 3720 3721 |
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
| | | 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 |
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
pgvPtr->value = ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
|
| ︙ | ︙ | |||
4179 4180 4181 4182 4183 4184 4185 |
*exactPtr = (anchorLeft && anchorRight);
}
return TCL_OK;
invalidGlob:
if (interp != NULL) {
| | | 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 |
*exactPtr = (anchorLeft && anchorRight);
}
return TCL_OK;
invalidGlob:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
}
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
Tcl_HashSearch *searchPtr);
static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
Tcl_Obj *key,
int *newPtr)
{
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
| > > > > > > > | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
Tcl_HashSearch *searchPtr);
static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
/*
* NOTE: VarHashCreateVar increments the recount of its key argument.
* All callers that will call Tcl_DecrRefCount on that argument must
* call Tcl_IncrRefCount on it before passing it in. This requirement
* can bubble up to callers of callers .... etc.
*/
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
Tcl_Obj *key,
int *newPtr)
{
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 |
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
| < > | | > | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
Var *varPtr;
Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1);
if (createPart1) {
Tcl_IncrRefCount(part1Ptr);
}
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
createPart1, createPart2, arrayPtrPtr);
TclDecrRefCount(part1Ptr);
return varPtr;
}
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 435 436 437 438 439 440 441 |
* VAR_UNDEFINED) by a trace.
*
* 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.
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
| > > | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
* VAR_UNDEFINED) by a trace.
*
* 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.
* When createPart1 is 1, callers must IncrRefCount part1Ptr if they
* plan to DecrRefCount it.
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
|
| ︙ | ︙ | |||
456 457 458 459 460 461 462 |
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
| | < < < | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
* name, if it doesn't already exist. If 0,
* return error if it doesn't exist. */
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
Tcl_Obj *part2Ptr = NULL;
Var *resPtr;
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
}
resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
flags, msg, createPart1, createPart2, arrayPtrPtr);
if (part2Ptr) {
Tcl_DecrRefCount(part2Ptr);
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
* if create is 1 (this only causes the hash table entry to be created).
* For example, the variable might be a global that has been unset but is
* still referenced by a procedure, or a variable that has been unset but
* it only being kept in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* A new hashtable entry may be created if create is 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupSimpleVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
| > | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
* if create is 1 (this only causes the hash table entry to be created).
* For example, the variable might be a global that has been unset but is
* still referenced by a procedure, or a variable that has been unset but
* it only being kept in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* A new hashtable entry may be created if create is 1.
* Callers must Incr varNamePtr if they plan to Decr it if create is 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupSimpleVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
const char *part1, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
const char *part2, /* If non-NULL, gives the name of an element
* in the array part1. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
| | < < < < < | 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 |
const char *part1, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
const char *part2, /* If non-NULL, gives the name of an element
* in the array part1. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
}
resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
Tcl_DecrRefCount(part1Ptr);
if (part2Ptr) {
Tcl_DecrRefCount(part2Ptr);
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 |
* NULL. */
const char *newValue, /* New value for variable. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
{
| < | < < < < < < < < < | < < < < < < < < | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 |
* NULL. */
const char *newValue, /* New value for variable. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
{
Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,
Tcl_NewStringObj(newValue, -1), flags);
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
/*
|
| ︙ | ︙ | |||
1693 1694 1695 1696 1697 1698 1699 |
* in the array part1. */
Tcl_Obj *newValuePtr, /* New value for variable. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
* TCL_LEAVE_ERR_MSG. */
{
| | < < < | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
* in the array part1. */
Tcl_Obj *newValuePtr, /* New value for variable. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
* TCL_LEAVE_ERR_MSG. */
{
Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
}
resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);
Tcl_DecrRefCount(part1Ptr);
if (part2Ptr) {
Tcl_DecrRefCount(part2Ptr);
|
| ︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 |
* left in the interpreter's result. Note that the returned object may
* not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
| > | 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 |
* left in the interpreter's result. Note that the returned object may
* not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
* Callers must Incr part1Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 |
*
* Side effects:
* The value of the given variable is incremented by the specified
* amount. If either the array or the entry didn't exist then a new
* variable is created. The ref count for the returned object is _not_
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclIncrObjVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
| > | 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 |
*
* Side effects:
* The value of the given variable is incremented by the specified
* amount. If either the array or the entry didn't exist then a new
* variable is created. The ref count for the returned object is _not_
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
* Callers must Incr part1Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclIncrObjVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
|
| ︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 |
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
int index) /* Index into the local variable table of the
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
| | < | < < | | < | | | | > | > > > > > > > > > > > > > > | > > | 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 |
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
int index) /* Index into the local variable table of the
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
register Tcl_Obj *varValuePtr;
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
}
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
varValuePtr = Tcl_NewIntObj(0);
}
if (Tcl_IsShared(varValuePtr)) {
/* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
varValuePtr, flags, index);
} else {
Tcl_DecrRefCount(varValuePtr);
return NULL;
}
} 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
* [incr] requires that write traces fire, and making this call
* is the way to make that happen.
*/
return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
varValuePtr, flags, index);
} else {
return NULL;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar --
*
|
| ︙ | ︙ | |||
2215 2216 2217 2218 2219 2220 2221 |
const char *part1, /* Name of variable or array. */
const char *part2, /* Name of element within array or NULL. */
int flags) /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
int result;
| | < < < | 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 |
const char *part1, /* Name of variable or array. */
const char *part2, /* Name of element within array or NULL. */
int flags) /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
int result;
Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
}
/*
* Filter to pass through only the flags this interface supports.
*/
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
|
| ︙ | ︙ | |||
2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
* TclSetupEnv routine.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
* A variable will be created if one does not already exist.
*
*----------------------------------------------------------------------
*/
int
TclArraySet(
Tcl_Interp *interp, /* Current interpreter. */
| > | 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 |
* TclSetupEnv routine.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
* A variable will be created if one does not already exist.
* Callers must Incr arrayNameObj if they pland to Decr it.
*
*----------------------------------------------------------------------
*/
int
TclArraySet(
Tcl_Interp *interp, /* Current interpreter. */
|
| ︙ | ︙ | |||
3061 3062 3063 3064 3065 3066 3067 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
| > | | 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", varName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
return TCL_ERROR;
}
/*
* Make a new array search with a free name.
*/
|
| ︙ | ︙ | |||
3156 3157 3158 3159 3160 3161 3162 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
| | | | 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
}
/*
* Get the search.
|
| ︙ | ︙ | |||
3262 3263 3264 3265 3266 3267 3268 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
| | | | 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
}
/*
* Get the search.
|
| ︙ | ︙ | |||
3372 3373 3374 3375 3376 3377 3378 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
| | | | 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
}
/*
* Get the search.
|
| ︙ | ︙ | |||
4015 4016 4017 4018 4019 4020 4021 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
| | | > | | 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 |
* Verify that it is indeed an array variable. This test comes after the
* traces - the variable may actually become an array as an effect of said
* traces.
*/
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", TclGetString(varNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
TclGetString(varNameObj), NULL);
return TCL_ERROR;
}
stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
if (stats == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error reading array statistics", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
ckfree(stats);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4216 4217 4218 4219 4220 4221 4222 |
/* ARGSUSED */
Tcl_Command
TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
| | | | | | | | | | | | | 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 |
/* ARGSUSED */
Tcl_Command
TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
{"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
{"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "array", arrayImplMap);
}
/*
|
| ︙ | ︙ | |||
4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 |
* A standard Tcl completion code. If an error occurs then an error
* message is left in iPtr->result.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
*
*----------------------------------------------------------------------
*/
static int
ObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
| > > | 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 |
* A standard Tcl completion code. If an error occurs then an error
* message is left in iPtr->result.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
* Callers must Incr myNamePtr if they plan to Decr it.
* Callers must Incr otherP1Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
static int
ObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 |
if (!(arrayPtr != NULL
? (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr))
: (TclIsVarInHash(otherPtr) && TclGetVarNsPtr(otherPtr)))
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
| | | | | 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 |
if (!(arrayPtr != NULL
? (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr))
: (TclIsVarInHash(otherPtr) && TclGetVarNsPtr(otherPtr)))
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
|| !HasLocalVars(varFramePtr)
|| (strstr(TclGetString(myNamePtr), "::") != NULL))) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"bad variable name \"%s\": upvar won't create "
"namespace variable that refers to procedure variable",
TclGetString(myNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
return TCL_ERROR;
}
}
return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
}
|
| ︙ | ︙ | |||
4357 4358 4359 4360 4361 4362 4363 |
const char *myName, /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
{
| | < < > > | 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 |
const char *myName, /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
{
Tcl_Obj *myNamePtr = NULL;
int result;
if (myName) {
myNamePtr = Tcl_NewStringObj(myName, -1);
Tcl_IncrRefCount(myNamePtr);
}
result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
if (myNamePtr) {
Tcl_DecrRefCount(myNamePtr);
}
return result;
}
/* Callers must Incr myNamePtr if they plan to Decr it. */
int
TclPtrObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
* error messages, too. */
Var *otherPtr, /* Pointer to the variable being linked-to. */
Tcl_Obj *myNamePtr, /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
|
| ︙ | ︙ | |||
4414 4415 4416 4417 4418 4419 4420 |
if (p != NULL) {
p += strlen(p)-1;
if (*p == ')') {
/*
* myName looks like an array reference.
*/
| | | | > | 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 |
if (p != NULL) {
p += strlen(p)-1;
if (*p == ')') {
/*
* myName looks like an array reference.
*/
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"bad variable name \"%s\": upvar won't create a"
" scalar variable that looks like an array element",
myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
4443 4444 4445 4446 4447 4448 4449 |
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(myNamePtr), NULL);
return TCL_ERROR;
}
}
if (varPtr == otherPtr) {
| | | | | | | | 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 |
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(myNamePtr), NULL);
return TCL_ERROR;
}
}
if (varPtr == otherPtr) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj(
"can't upvar from variable to itself", -1));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL);
return TCL_ERROR;
}
if (TclIsVarTraced(varPtr)) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"variable \"%s\" has traces: can't use for upvar", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
Var *linkPtr;
/*
* The variable already existed. Make sure this variable "varPtr"
* isn't the same as "otherPtr" (avoid circular links). Also, if it's
* not an upvar then it's an error. If it is an upvar, then just
* disconnect it from the thing it currently refers to.
*/
if (!TclIsVarLink(varPtr)) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"variable \"%s\" already exists", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL);
return TCL_ERROR;
}
linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
return TCL_OK;
|
| ︙ | ︙ | |||
4964 4965 4966 4967 4968 4969 4970 |
}
if ((result == 0) && hasLevel) {
/*
* Synthesize an error message since TclObjGetFrame doesn't do this
* for this particular case.
*/
| > | < | | | 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 |
}
if ((result == 0) && hasLevel) {
/*
* Synthesize an error message since TclObjGetFrame doesn't do this
* for this particular case.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(levelObj)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
return TCL_ERROR;
}
/*
* We've now finished with parsing levels; skip to the variable names.
*/
objc -= hasLevel + 1;
objv += hasLevel + 1;
/*
* Iterate over each (other variable, local variable) pair. Divide the
* other variable name into two parts, then call MakeUpvar to do all the
* work of linking it to the local variable.
*/
|
| ︙ | ︙ | |||
5056 5057 5058 5059 5060 5061 5062 |
TclFreeIntRep(objPtr);
objPtr->typePtr = &tclArraySearchType;
objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id);
objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset);
return TCL_OK;
syntax:
| > | < | 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 |
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5122 5123 5124 5125 5126 5127 5128 |
/*
* This test cannot be placed inside the Tcl_Obj machinery, since it is
* dependent on the variable context.
*/
if (strcmp(string+offset, varName) != 0) {
| | | | < | 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 |
/*
* 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.
*
|
| ︙ | ︙ | |||
5149 5150 5151 5152 5153 5154 5155 |
for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (searchPtr->id == id) {
return searchPtr;
}
}
}
| > | | 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 |
for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (searchPtr->id == id) {
return searchPtr;
}
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't find search \"%s\"", string));
badLookup:
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
5235 5236 5237 5238 5239 5240 5241 |
} else if (nsPtr == (Namespace *) TclGetCurrentNamespace(interp)) {
flags = TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr = Tcl_NewObj();
| < < | 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 |
} else if (nsPtr == (Namespace *) TclGetCurrentNamespace(interp)) {
flags = TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr = Tcl_NewObj();
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags,
-1);
Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */
|
| ︙ | ︙ | |||
5500 5501 5502 5503 5504 5505 5506 |
Tcl_Interp *interp, /* Interpreter in which to record message. */
const char *part1,
const char *part2, /* Variable's two-part name. */
const char *operation, /* String describing operation that failed,
* e.g. "read", "set", or "unset". */
const char *reason) /* String describing why operation failed. */
{
| | < < < < < | 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 |
Tcl_Interp *interp, /* Interpreter in which to record message. */
const char *part1,
const char *part2, /* Variable's two-part name. */
const char *operation, /* String describing operation that failed,
* e.g. "read", "set", or "unset". */
const char *reason) /* String describing why operation failed. */
{
Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
}
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);
Tcl_DecrRefCount(part1Ptr);
if (part2Ptr) {
Tcl_DecrRefCount(part2Ptr);
|
| ︙ | ︙ | |||
5781 5782 5783 5784 5785 5786 5787 |
* TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY are given,
* TCL_GLOBAL_ONLY is ignored. */
{
Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
Tcl_Var var;
| < | 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 |
* TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY are given,
* TCL_GLOBAL_ONLY is ignored. */
{
Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
Tcl_Var var;
var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags);
Tcl_DecrRefCount(namePtr);
return var;
}
static Tcl_Var
ObjFindNamespaceVar(
|
| ︙ | ︙ | |||
5876 5877 5878 5879 5880 5881 5882 |
* to check both possible search paths: from the specified namespace
* context and from the global namespace.
*/
varPtr = NULL;
if (simpleName != name) {
simpleNamePtr = Tcl_NewStringObj(simpleName, -1);
| < | | | 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 |
* to check both possible search paths: from the specified namespace
* context and from the global namespace.
*/
varPtr = NULL;
if (simpleName != name) {
simpleNamePtr = Tcl_NewStringObj(simpleName, -1);
} else {
simpleNamePtr = namePtr;
}
for (search = 0; (search < 2) && (varPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr);
}
}
if (simpleName != name) {
Tcl_DecrRefCount(simpleNamePtr);
}
if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown variable \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL);
}
return (Tcl_Var) varPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
1 2 3 4 5 6 7 | /* * tclZlib.c -- * * This file provides the interface to the Zlib library. * * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net> * Copyright (C) 2005 Unitas Software B.V. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclZlib.c -- * * This file provides the interface to the Zlib library. * * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net> * Copyright (C) 2005 Unitas Software B.V. * Copyright (c) 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ |
| ︙ | ︙ | |||
70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
int format; /* Flags from the TCL_ZLIB_FORMAT_* */
int level; /* Default 5, 0-9 */
int flush; /* Stores the flush param for deferred the
* decompression. */
int wbits; /* The encoded compression mode, so we can
* restart the stream if necessary. */
Tcl_Command cmd; /* Token for the associated Tcl command. */
} ZlibStreamHandle;
/*
* Structure used for stacked channel compression and decompression.
*/
typedef struct {
Tcl_Channel chan; /* Reference to the channel itself. */
Tcl_Channel parent; /* The underlying source and sink of bytes. */
int flags; /* General flag bits, see below... */
int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
* for compression on output, or
* TCL_ZLIB_STREAM_INFLATE for decompression
* on input. */
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;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
GzipHeader outHeader; /* Header to write to an output stream, when
* compressing a gzip stream. */
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
Tcl_DString decompressed; /* Buffer for decompression results. */
} ZlibChannelData;
/*
* Value bits for the flags field. Definitions are:
* ASYNC - Whether this is an asynchronous channel.
* IN_HEADER - Whether the inHeader field has been registered with
* the input compressor.
* OUT_HEADER - Whether the outputHeader field has been registered
* with the output decompressor.
*/
#define ASYNC 0x1
#define IN_HEADER 0x2
#define OUT_HEADER 0x4
/*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > > | | > > > | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
int format; /* Flags from the TCL_ZLIB_FORMAT_* */
int level; /* Default 5, 0-9 */
int flush; /* Stores the flush param for deferred the
* decompression. */
int wbits; /* The encoded compression mode, so we can
* restart the stream if necessary. */
Tcl_Command cmd; /* Token for the associated Tcl command. */
Tcl_Obj *compDictObj; /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
int flags; /* Miscellaneous flag bits. */
GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header
* structure. */
} ZlibStreamHandle;
#define DICT_TO_SET 0x1 /* If we need to set a compression dictionary
* in the low-level engine at the next
* opportunity. */
/*
* Macros to make it clearer in some of the twiddlier accesses what is
* happening.
*/
#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW)
#define HaveDictToSet(zshPtr) ((zshPtr)->flags & DICT_TO_SET)
#define DictWasSet(zshPtr) ((zshPtr)->flags |= ~DICT_TO_SET)
/*
* Structure used for stacked channel compression and decompression.
*/
typedef struct {
Tcl_Channel chan; /* Reference to the channel itself. */
Tcl_Channel parent; /* The underlying source and sink of bytes. */
int flags; /* General flag bits, see below... */
int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
* for compression on output, or
* TCL_ZLIB_STREAM_INFLATE for decompression
* on input. */
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
* 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;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
GzipHeader outHeader; /* Header to write to an output stream, when
* compressing a gzip stream. */
Tcl_TimerToken timer; /* Timer used for keeping events fresh. */
Tcl_DString decompressed; /* Buffer for decompression results. */
Tcl_Obj *compDictObj; /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
} ZlibChannelData;
/*
* Value bits for the flags field. Definitions are:
* ASYNC - Whether this is an asynchronous channel.
* IN_HEADER - Whether the inHeader field has been registered with
* the input compressor.
* OUT_HEADER - Whether the outputHeader field has been registered
* with the output decompressor.
*/
#define ASYNC 0x1
#define IN_HEADER 0x2
#define OUT_HEADER 0x4
/*
* Size of buffers allocated by default, and the range it can be set to. The
* same sorts of values apply to streams, except with different limits (they
* permit byte-level activity). Channels always use bytes unless told to use
* larger buffers.
*/
#define DEFAULT_BUFFER_SIZE 4096
#define MIN_NONSTREAM_BUFFER_SIZE 16
#define MAX_BUFFER_SIZE 65536
/*
* Prototypes for private procedures defined later in this file:
*/
static Tcl_CmdDeleteProc ZlibStreamCmdDelete;
static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
static Tcl_DriverCloseProc ZlibTransformClose;
static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
static Tcl_DriverGetOptionProc ZlibTransformGetOption;
static Tcl_DriverHandlerProc ZlibTransformEventHandler;
static Tcl_DriverInputProc ZlibTransformInput;
static Tcl_DriverOutputProc ZlibTransformOutput;
static Tcl_DriverSetOptionProc ZlibTransformSetOption;
static Tcl_DriverWatchProc ZlibTransformWatch;
static Tcl_ObjCmdProc ZlibCmd;
static Tcl_ObjCmdProc ZlibStreamCmd;
static Tcl_ObjCmdProc ZlibStreamAddCmd;
static Tcl_ObjCmdProc ZlibStreamHeaderCmd;
static Tcl_ObjCmdProc ZlibStreamPutCmd;
static void ConvertError(Tcl_Interp *interp, int code,
uLong adler);
static Tcl_Obj * ConvertErrorToList(int code, uLong adler);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
static int ZlibPushSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline int ResultCopy(ZlibChannelData *cd, char *buf,
int toRead);
static int ResultGenerate(ZlibChannelData *cd, int n, int flush,
int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
int mode, int format, int level, int limit,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr,
Tcl_Obj *compDictObj);
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);
/*
* Type of zlib-based compressing and decompressing channels.
*/
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
*----------------------------------------------------------------------
*/
static void
ConvertError(
Tcl_Interp *interp, /* Interpreter to store the error in. May be
* NULL, in which case nothing happens. */
| | > > > > > > > > > > > > | | | > > > | > < | > > | > > | > > | > > | > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | > | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
*----------------------------------------------------------------------
*/
static void
ConvertError(
Tcl_Interp *interp, /* Interpreter to store the error in. May be
* NULL, in which case nothing happens. */
int code, /* The zlib error code. */
uLong adler) /* The checksum expected (for Z_NEED_DICT) */
{
const char *codeStr, *codeStr2 = NULL;
char codeStrBuf[TCL_INTEGER_SPACE];
if (interp == NULL) {
return;
}
switch (code) {
/*
* Firstly, the case that is *different* because it's really coming
* from the OS and is just being reported via zlib. It should be
* really uncommon because Tcl handles all I/O rather than delegating
* it to zlib, but proving it can't happen is hard.
*/
case Z_ERRNO:
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1));
return;
/*
* Normal errors/conditions, some of which have additional detail and
* some which don't. (This is not defined by array lookup because zlib
* error codes are sometimes negative.)
*/
case Z_STREAM_ERROR:
codeStr = "STREAM";
break;
case Z_DATA_ERROR:
codeStr = "DATA";
break;
case Z_MEM_ERROR:
codeStr = "MEM";
break;
case Z_BUF_ERROR:
codeStr = "BUF";
break;
case Z_VERSION_ERROR:
codeStr = "VERSION";
break;
case Z_NEED_DICT:
codeStr = "NEED_DICT";
codeStr2 = codeStrBuf;
sprintf(codeStrBuf, "%lu", adler);
break;
/*
* These should _not_ happen! This function is for dealing with error
* cases, not non-errors!
*/
case Z_OK:
Tcl_Panic("unexpected zlib result in error handler: Z_OK");
case Z_STREAM_END:
Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END");
/*
* Anything else is bad news; it's unexpected. Convert to generic
* error.
*/
default:
codeStr = "UNKNOWN";
codeStr2 = codeStrBuf;
sprintf(codeStrBuf, "%d", code);
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1));
/*
* Tricky point! We might pass NULL twice here (and will when the error
* type is known).
*/
Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL);
}
static Tcl_Obj *
ConvertErrorToList(
int code, /* The zlib error code. */
uLong adler) /* The checksum expected (for Z_NEED_DICT) */
{
Tcl_Obj *objv[4];
TclNewLiteralStringObj(objv[0], "TCL");
TclNewLiteralStringObj(objv[1], "ZLIB");
switch (code) {
case Z_STREAM_ERROR:
TclNewLiteralStringObj(objv[2], "STREAM");
return Tcl_NewListObj(3, objv);
case Z_DATA_ERROR:
TclNewLiteralStringObj(objv[2], "DATA");
return Tcl_NewListObj(3, objv);
case Z_MEM_ERROR:
TclNewLiteralStringObj(objv[2], "MEM");
return Tcl_NewListObj(3, objv);
case Z_BUF_ERROR:
TclNewLiteralStringObj(objv[2], "BUF");
return Tcl_NewListObj(3, objv);
case Z_VERSION_ERROR:
TclNewLiteralStringObj(objv[2], "VERSION");
return Tcl_NewListObj(3, objv);
case Z_ERRNO:
TclNewLiteralStringObj(objv[2], "POSIX");
objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
return Tcl_NewListObj(4, objv);
case Z_NEED_DICT:
TclNewLiteralStringObj(objv[2], "NEED_DICT");
objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler);
return Tcl_NewListObj(4, objv);
/*
* These should _not_ happen! This function is for dealing with error
* cases, not non-errors!
*/
case Z_OK:
Tcl_Panic("unexpected zlib result in error handler: Z_OK");
case Z_STREAM_END:
Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END");
/*
* Catch-all. Should be unreachable because all cases are already
* listed above.
*/
default:
TclNewLiteralStringObj(objv[2], "UNKNOWN");
TclNewIntObj(objv[3], code);
return Tcl_NewListObj(4, objv);
}
}
/*
*----------------------------------------------------------------------
*
* GenerateHeader --
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 |
} else if (value != NULL) {
valueStr = Tcl_GetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
NULL);
headerPtr->nativeCommentBuf[len] = '\0';
headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf;
| > | > > | > | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
} else if (value != NULL) {
valueStr = Tcl_GetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
NULL);
headerPtr->nativeCommentBuf[len] = '\0';
headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf;
if (extraSizePtr != NULL) {
*extraSizePtr += len;
}
}
if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) {
goto error;
} else if (value != NULL &&
Tcl_GetBooleanFromObj(interp, value, &headerPtr->header.hcrc)) {
goto error;
}
if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
valueStr = Tcl_GetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL);
headerPtr->nativeFilenameBuf[len] = '\0';
headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf;
if (extraSizePtr != NULL) {
*extraSizePtr += len;
}
}
if (GetValue(interp, dictObj, "os", &value) != TCL_OK) {
goto error;
} else if (value != NULL && Tcl_GetIntFromObj(interp, value,
&headerPtr->header.os) != TCL_OK) {
goto error;
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 | /* *---------------------------------------------------------------------- * * ExtractHeader -- * * Take the values out of a gzip header and store them in a dictionary. | | < | < < < < < < < | < < | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 |
/*
*----------------------------------------------------------------------
*
* ExtractHeader --
*
* Take the values out of a gzip header and store them in a dictionary.
* SetValue is a helper macro.
*
* Results:
* None.
*
* Side effects:
* Updates the dictionary, which must be writable (i.e. refCount < 2).
*
*----------------------------------------------------------------------
*/
#define SetValue(dictObj, key, value) \
Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value))
static void
ExtractHeader(
gz_header *headerPtr, /* The gzip header to extract from. */
Tcl_Obj *dictObj) /* The dictionary to store in. */
{
Tcl_Encoding latin1enc = NULL;
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 443 444 445 446 447 448 449 |
Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1));
}
if (latin1enc != NULL) {
Tcl_FreeEncoding(latin1enc);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibStreamInit --
*
* This command initializes a (de)compression context/handle for
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1));
}
if (latin1enc != NULL) {
Tcl_FreeEncoding(latin1enc);
}
}
static int
SetInflateDictionary(
z_streamp strm,
Tcl_Obj *compDictObj)
{
if (compDictObj != NULL) {
int length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length);
return inflateSetDictionary(strm, bytes, (unsigned) length);
}
return Z_OK;
}
static int
SetDeflateDictionary(
z_streamp strm,
Tcl_Obj *compDictObj)
{
if (compDictObj != NULL) {
int length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length);
return deflateSetDictionary(strm, bytes, (unsigned) length);
}
return Z_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibStreamInit --
*
* This command initializes a (de)compression context/handle for
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 |
Tcl_ZlibStream *zshandlePtr)
{
int wbits = 0;
int e;
ZlibStreamHandle *zshPtr = NULL;
Tcl_DString cmdname;
Tcl_CmdInfo cmdinfo;
switch (mode) {
case TCL_ZLIB_STREAM_DEFLATE:
/*
* Compressed format is specified by the wbits parameter. See zlib.h
* for details.
*/
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
default:
Tcl_Panic("incorrect zlib data format, must be "
"TCL_ZLIB_FORMAT_ZLIB, TCL_ZLIB_FORMAT_GZIP or "
| > > > > > > > > > > | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 |
Tcl_ZlibStream *zshandlePtr)
{
int wbits = 0;
int e;
ZlibStreamHandle *zshPtr = NULL;
Tcl_DString cmdname;
Tcl_CmdInfo cmdinfo;
GzipHeader *gzHeaderPtr = NULL;
switch (mode) {
case TCL_ZLIB_STREAM_DEFLATE:
/*
* Compressed format is specified by the wbits parameter. See zlib.h
* for details.
*/
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
gzHeaderPtr = ckalloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
if (GenerateHeader(interp, dictObj, gzHeaderPtr,
NULL) != TCL_OK) {
ckfree(gzHeaderPtr);
return TCL_ERROR;
}
}
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
default:
Tcl_Panic("incorrect zlib data format, must be "
"TCL_ZLIB_FORMAT_ZLIB, TCL_ZLIB_FORMAT_GZIP or "
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
case TCL_ZLIB_FORMAT_AUTO:
wbits = WBITS_AUTODETECT;
break;
| > > > > > > > > | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
gzHeaderPtr = ckalloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
gzHeaderPtr->header.name = (Bytef *)
gzHeaderPtr->nativeFilenameBuf;
gzHeaderPtr->header.name_max = MAXPATHLEN - 1;
gzHeaderPtr->header.comment = (Bytef *)
gzHeaderPtr->nativeCommentBuf;
gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1;
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
case TCL_ZLIB_FORMAT_AUTO:
wbits = WBITS_AUTODETECT;
break;
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
zshPtr->interp = interp;
zshPtr->mode = mode;
zshPtr->format = format;
zshPtr->level = level;
zshPtr->wbits = wbits;
zshPtr->currentInput = NULL;
zshPtr->streamEnd = 0;
memset(&zshPtr->stream, 0, sizeof(z_stream));
zshPtr->stream.adler = 1;
/*
* No output buffer available yet
*/
if (mode == TCL_ZLIB_STREAM_DEFLATE) {
e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
} else {
e = inflateInit2(&zshPtr->stream, wbits);
}
if (e != Z_OK) {
| > > > > > > > > > > > | | | < | | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
zshPtr->interp = interp;
zshPtr->mode = mode;
zshPtr->format = format;
zshPtr->level = level;
zshPtr->wbits = wbits;
zshPtr->currentInput = NULL;
zshPtr->streamEnd = 0;
zshPtr->compDictObj = NULL;
zshPtr->flags = 0;
zshPtr->gzHeaderPtr = gzHeaderPtr;
memset(&zshPtr->stream, 0, sizeof(z_stream));
zshPtr->stream.adler = 1;
/*
* No output buffer available yet
*/
if (mode == TCL_ZLIB_STREAM_DEFLATE) {
e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
if (e == Z_OK && zshPtr->gzHeaderPtr) {
e = deflateSetHeader(&zshPtr->stream,
&zshPtr->gzHeaderPtr->header);
}
} else {
e = inflateInit2(&zshPtr->stream, wbits);
if (e == Z_OK && zshPtr->gzHeaderPtr) {
e = inflateGetHeader(&zshPtr->stream,
&zshPtr->gzHeaderPtr->header);
}
}
if (e != Z_OK) {
ConvertError(interp, e, zshPtr->stream.adler);
goto error;
}
/*
* I could do all this in C, but this is easier.
*/
if (interp != NULL) {
if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) {
goto error;
}
Tcl_DStringInit(&cmdname);
TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname),
&cmdinfo) == 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"BUG: Stream command name already exists", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
Tcl_DStringFree(&cmdname);
goto error;
}
Tcl_ResetResult(interp);
/*
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
*/
if (zshandlePtr) {
*zshandlePtr = (Tcl_ZlibStream) zshPtr;
}
return TCL_OK;
| > | > > > > > > | 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
*/
if (zshandlePtr) {
*zshandlePtr = (Tcl_ZlibStream) zshPtr;
}
return TCL_OK;
error:
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
ckfree(zshPtr->gzHeaderPtr);
}
ckfree(zshPtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 732 733 734 735 736 737 738 |
}
if (zshPtr->outData) {
Tcl_DecrRefCount(zshPtr->outData);
}
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
}
ckfree(zshPtr);
}
/*
*----------------------------------------------------------------------
*
| > > > > > > | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
}
if (zshPtr->outData) {
Tcl_DecrRefCount(zshPtr->outData);
}
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
}
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
ckfree(zshPtr->gzHeaderPtr);
}
ckfree(zshPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 784 785 786 787 788 |
/*
* No output buffer available yet.
*/
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED,
zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
} else {
e = inflateInit2(&zshPtr->stream, zshPtr->wbits);
}
if (e != Z_OK) {
| > > > > > > > > > > > > | | 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
/*
* No output buffer available yet.
*/
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED,
zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
if (e == Z_OK && HaveDictToSet(zshPtr)) {
e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
}
}
} else {
e = inflateInit2(&zshPtr->stream, zshPtr->wbits);
if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr) && e == Z_OK) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
}
}
}
if (e != Z_OK) {
ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
/* TODO:cleanup */
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
return zshPtr->stream.adler;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibStreamPut --
*
* Add data to the stream for compression or decompression from a
* bytearray Tcl_Obj.
*
*----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 |
return zshPtr->stream.adler;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibStreamSetCompressionDictionary --
*
* Sets the compression dictionary for a stream. This will be used as
* appropriate for the next compression or decompression action performed
* on the stream.
*
*----------------------------------------------------------------------
*/
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
} else {
zshPtr->flags &= ~DICT_TO_SET;
}
if (zshPtr->compDictObj != NULL) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
zshPtr->compDictObj = compressionDictionaryObj;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibStreamPut --
*
* Add data to the stream for compression or decompression from a
* bytearray Tcl_Obj.
*
*----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 |
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize;
Tcl_Obj *obj;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
| | | > > > > > > > > > > > | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize;
Tcl_Obj *obj;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size);
zshPtr->stream.avail_in = size;
if (HaveDictToSet(zshPtr)) {
e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
if (zshPtr->interp) {
ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
}
return TCL_ERROR;
}
DictWasSet(zshPtr);
}
/*
* Deflatebound doesn't seem to take various header sizes into
* account, so we add 100 extra bytes.
*/
outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100;
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
ckfree(dataTmp);
dataTmp = ckalloc(outSize);
}
zshPtr->stream.avail_out = outSize;
zshPtr->stream.next_out = (Bytef *) dataTmp;
e = deflate(&zshPtr->stream, flush);
}
/*
* And append the final data block.
*/
if (outSize - zshPtr->stream.avail_out > 0) {
| > > > > > > | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 |
ckfree(dataTmp);
dataTmp = ckalloc(outSize);
}
zshPtr->stream.avail_out = outSize;
zshPtr->stream.next_out = (Bytef *) dataTmp;
e = deflate(&zshPtr->stream, flush);
}
if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) {
if (zshPtr->interp) {
ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
}
return TCL_ERROR;
}
/*
* And append the final data block.
*/
if (outSize - zshPtr->stream.avail_out > 0) {
|
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 |
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == -1) {
/*
* The only safe thing to do is restict to 65k. We might cause a
* panic for out of memory if we just kept growing the buffer.
*/
| | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == -1) {
/*
* The only safe thing to do is restict to 65k. We might cause a
* panic for out of memory if we just kept growing the buffer.
*/
count = MAX_BUFFER_SIZE;
}
/*
* Prepare the place to store the data.
*/
dataPtr = Tcl_SetByteArrayLength(data, existing+count);
|
| ︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 |
* And remove it from the list
*/
Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL);
}
}
e = inflate(&zshPtr->stream, zshPtr->flush);
Tcl_ListObjLength(NULL, zshPtr->inData, &listLen);
while ((zshPtr->stream.avail_out > 0)
&& (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
/*
* State: We have not satisfied the request yet and there may be
* more to inflate.
*/
if (zshPtr->stream.avail_in > 0) {
if (zshPtr->interp) {
| > > > > > > > > > > > > > > > > > > > > > > > | | | | 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 |
* And remove it from the list
*/
Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL);
}
}
/*
* When dealing with a raw stream, we set the dictionary here, once.
* (You can't do it in response to getting Z_NEED_DATA as raw streams
* don't ever issue that.)
*/
if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
if (zshPtr->interp) {
ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
}
return TCL_ERROR;
}
DictWasSet(zshPtr);
}
e = inflate(&zshPtr->stream, zshPtr->flush);
if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e == Z_OK) {
DictWasSet(zshPtr);
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
Tcl_ListObjLength(NULL, zshPtr->inData, &listLen);
while ((zshPtr->stream.avail_out > 0)
&& (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
/*
* State: We have not satisfied the request yet and there may be
* more to inflate.
*/
if (zshPtr->stream.avail_in > 0) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"unexpected zlib internal state during"
" decompression", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
NULL);
}
Tcl_SetByteArrayLength(data, existing);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 | Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL); listLen--; /* * And call inflate again. */ | > | > > > > > > | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 |
Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL);
listLen--;
/*
* And call inflate again.
*/
do {
e = inflate(&zshPtr->stream, zshPtr->flush);
if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) {
break;
}
e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj);
DictWasSet(zshPtr);
} while (e == Z_OK);
}
if (zshPtr->stream.avail_out > 0) {
Tcl_SetByteArrayLength(data,
existing + count - zshPtr->stream.avail_out);
}
if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) {
Tcl_SetByteArrayLength(data, existing);
ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
return TCL_ERROR;
}
if (e == Z_STREAM_END) {
zshPtr->streamEnd = 1;
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 |
*/
Tcl_SetByteArrayLength(obj, stream.total_out);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
error:
| | | 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 |
*/
Tcl_SetByteArrayLength(obj, stream.total_out);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
error:
ConvertError(interp, e, stream.adler);
TclDecrRefCount(obj);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 |
ckfree(commentBuf);
}
Tcl_SetObjResult(interp, obj);
return TCL_OK;
error:
TclDecrRefCount(obj);
| | | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
ckfree(commentBuf);
}
Tcl_SetObjResult(interp, obj);
return TCL_OK;
error:
TclDecrRefCount(obj);
ConvertError(interp, e, stream.adler);
if (nameBuf) {
ckfree(nameBuf);
}
if (commentBuf) {
ckfree(commentBuf);
}
return TCL_ERROR;
|
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 |
static int
ZlibCmd(
ClientData notUsed,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | < | < < < < < < < < | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 |
static int
ZlibCmd(
ClientData notUsed,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int command, dlen, i, option, level = -1;
unsigned start, buffersize = 0;
Byte *data;
Tcl_Obj *headerDictObj;
const char *extraInfoStr = NULL;
static const char *const commands[] = {
"adler32", "compress", "crc32", "decompress", "deflate", "gunzip",
"gzip", "inflate", "push", "stream",
NULL
};
enum zlibCommands {
CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE,
CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0,
&command) != TCL_OK) {
|
| ︙ | ︙ | |||
1632 1633 1634 1635 1636 1637 1638 |
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
| | | | 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
return TCL_ERROR;
}
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;
case CMD_CRC: /* crc32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
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;
case CMD_DEFLATE: /* deflate data ?level?
* -> rawCompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 |
goto badLevel;
}
}
return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], level,
NULL);
case CMD_GZIP: /* gzip data ?level?
* -> gzippedCompressedData */
if (objc < 3 || objc > 7 || ((objc & 1) == 0)) {
Tcl_WrongNumArgs(interp, 2, objv,
"data ?-level level? ?-header header?");
return TCL_ERROR;
}
| > > > > > > > > > > > > > > > > < | 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 |
goto badLevel;
}
}
return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], level,
NULL);
case CMD_GZIP: /* gzip data ?level?
* -> gzippedCompressedData */
headerDictObj = NULL;
/*
* Legacy argument format support.
*/
if (objc == 4
&& Tcl_GetIntFromObj(interp, objv[3], &level) == TCL_OK) {
if (level < 0 || level > 9) {
extraInfoStr = "\n (in -level option)";
goto badLevel;
}
return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2],
level, NULL);
}
if (objc < 3 || objc > 7 || ((objc & 1) == 0)) {
Tcl_WrongNumArgs(interp, 2, objv,
"data ?-level level? ?-header header?");
return TCL_ERROR;
}
for (i=3 ; i<objc ; i+=2) {
static const char *const gzipopts[] = {
"-header", "-level", NULL
};
if (Tcl_GetIndexFromObj(interp, objv[i], gzipopts, "option", 0,
&option) != TCL_OK) {
|
| ︙ | ︙ | |||
1729 1730 1731 1732 1733 1734 1735 |
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
| > | > | | > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < | < < < | < < < < < < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | < < | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < | < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 |
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
}
return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2],
buffersize, NULL);
case CMD_DECOMPRESS: /* decompress zlibcomprdata \
* ?bufferSize?
* -> decompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
}
return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2],
buffersize, NULL);
case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize?
* -> decompressedData */
Tcl_Obj *headerVarObj;
if (objc < 3 || objc > 5 || ((objc & 1) == 0)) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?");
return TCL_ERROR;
}
headerDictObj = headerVarObj = NULL;
for (i=3 ; i<objc ; i+=2) {
static const char *const gunzipopts[] = {
"-buffersize", "-headerVar", NULL
};
if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
if (Tcl_GetIntFromObj(interp, objv[i+1],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
break;
case 1:
headerVarObj = objv[i+1];
headerDictObj = Tcl_NewObj();
break;
}
}
if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2],
buffersize, headerDictObj) != TCL_OK) {
if (headerDictObj) {
TclDecrRefCount(headerDictObj);
}
return TCL_ERROR;
}
if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL,
headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
case CMD_STREAM: /* stream deflate/inflate/...gunzip \
* ?options...?
* -> handleCmd */
return ZlibStreamSubcmd(interp, objc, objv);
case CMD_PUSH: /* push mode channel options...
* -> channel */
return ZlibPushSubcmd(interp, objc, objv);
};
return TCL_ERROR;
badLevel:
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
if (extraInfoStr) {
Tcl_AddErrorInfo(interp, extraInfoStr);
}
return TCL_ERROR;
badBuffer:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"buffer size must be %d to %d",
MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ZlibStreamSubcmd --
*
* Implementation of the [zlib stream] subcommand.
*
*----------------------------------------------------------------------
*/
static int
ZlibStreamSubcmd(
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const stream_formats[] = {
"compress", "decompress", "deflate", "gunzip", "gzip", "inflate",
NULL
};
enum zlibFormats {
FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP,
FMT_INFLATE
};
int i, format, mode = 0, option, level;
enum objIndices {
OPT_COMPRESSION_DICTIONARY = 0,
OPT_GZIP_HEADER = 1,
OPT_COMPRESSION_LEVEL = 2,
OPT_END = -1
};
Tcl_Obj *obj[3] = { NULL, NULL, NULL };
#define compDictObj obj[OPT_COMPRESSION_DICTIONARY]
#define gzipHeaderObj obj[OPT_GZIP_HEADER]
#define levelObj obj[OPT_COMPRESSION_LEVEL]
typedef struct {
const char *name;
enum objIndices offset;
} OptDescriptor;
static const OptDescriptor compressionOpts[] = {
{ "-dictionary", OPT_COMPRESSION_DICTIONARY },
{ "-level", OPT_COMPRESSION_LEVEL },
{ NULL, OPT_END }
};
static const OptDescriptor gzipOpts[] = {
{ "-header", OPT_GZIP_HEADER },
{ "-level", OPT_COMPRESSION_LEVEL },
{ NULL, OPT_END }
};
static const OptDescriptor expansionOpts[] = {
{ "-dictionary", OPT_COMPRESSION_DICTIONARY },
{ NULL, OPT_END }
};
static const OptDescriptor gunzipOpts[] = {
{ NULL, OPT_END }
};
const OptDescriptor *desc = NULL;
Tcl_ZlibStream zh;
if (objc < 3 || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
&format) != TCL_OK) {
return TCL_ERROR;
}
/*
* The format determines the compression mode and the options that may be
* specified.
*/
switch ((enum zlibFormats) format) {
case FMT_DEFLATE:
desc = compressionOpts;
mode = TCL_ZLIB_STREAM_DEFLATE;
format = TCL_ZLIB_FORMAT_RAW;
break;
case FMT_INFLATE:
desc = expansionOpts;
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_RAW;
break;
case FMT_COMPRESS:
desc = compressionOpts;
mode = TCL_ZLIB_STREAM_DEFLATE;
format = TCL_ZLIB_FORMAT_ZLIB;
break;
case FMT_DECOMPRESS:
desc = expansionOpts;
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_ZLIB;
break;
case FMT_GZIP:
desc = gzipOpts;
mode = TCL_ZLIB_STREAM_DEFLATE;
format = TCL_ZLIB_FORMAT_GZIP;
break;
case FMT_GUNZIP:
desc = gunzipOpts;
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
Tcl_Panic("should be unreachable");
}
/*
* Parse the options.
*/
for (i=3 ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObjStruct(interp, objv[i], desc,
sizeof(OptDescriptor), "option", 0, &option) != TCL_OK) {
return TCL_ERROR;
}
obj[desc[option].offset] = objv[i+1];
}
/*
* If a compression level was given, parse it (integral: 0..9). Otherwise
* use the default.
*/
if (levelObj == NULL) {
level = Z_DEFAULT_COMPRESSION;
} else if (Tcl_GetIntFromObj(interp, levelObj, &level) != TCL_OK) {
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
return TCL_ERROR;
}
if (compDictObj != NULL) {
Tcl_ZlibStreamSetCompressionDictionary(zh, compDictObj);
}
Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh));
return TCL_OK;
#undef compDictObj
#undef gzipHeaderObj
#undef levelObj
}
/*
*----------------------------------------------------------------------
*
* ZlibPushSubcmd --
*
* Implementation of the [zlib push] subcommand.
*
*----------------------------------------------------------------------
*/
static int
ZlibPushSubcmd(
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const stream_formats[] = {
"compress", "decompress", "deflate", "gunzip", "gzip", "inflate",
NULL
};
enum zlibFormats {
FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP,
FMT_INFLATE
};
Tcl_Channel chan;
int chanMode, format, mode = 0, level, i, option;
static const char *const pushCompressOptions[] = {
"-dictionary", "-header", "-level", NULL
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
enum pushOptions {poDictionary, poHeader, poLevel, poLimit};
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
int limit = 1, dummy;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
&format) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum zlibFormats) format) {
case FMT_DEFLATE:
mode = TCL_ZLIB_STREAM_DEFLATE;
format = TCL_ZLIB_FORMAT_RAW;
pushOptions = pushCompressOptions;
break;
case FMT_INFLATE:
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_RAW;
break;
case FMT_COMPRESS:
mode = TCL_ZLIB_STREAM_DEFLATE;
format = TCL_ZLIB_FORMAT_ZLIB;
pushOptions = pushCompressOptions;
break;
case FMT_DECOMPRESS:
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_ZLIB;
break;
case FMT_GZIP:
mode = TCL_ZLIB_STREAM_DEFLATE;
format = TCL_ZLIB_FORMAT_GZIP;
pushOptions = pushCompressOptions;
break;
case FMT_GUNZIP:
mode = TCL_ZLIB_STREAM_INFLATE;
format = TCL_ZLIB_FORMAT_GZIP;
break;
default:
Tcl_Panic("should be unreachable");
}
if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){
return TCL_ERROR;
}
/*
* Sanity checks.
*/
if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"compression may only be applied to writable channels", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
return TCL_ERROR;
}
if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"decompression may only be applied to readable channels",-1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);
return TCL_ERROR;
}
/*
* Parse options.
*/
level = Z_DEFAULT_COMPRESSION;
for (i=4 ; i<objc ; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], pushOptions, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
if (++i > objc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value missing for %s option", pushOptions[option]));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
switch ((enum pushOptions) option) {
case poHeader:
headerObj = objv[i];
if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
goto genericOptionError;
}
break;
case poLevel:
if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) {
goto genericOptionError;
}
if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"level must be 0 to 9", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
NULL);
goto genericOptionError;
}
break;
case poLimit:
if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) {
goto genericOptionError;
}
if (limit < 1 || limit > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"read ahead limit must be 1 to %d",
MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
goto genericOptionError;
}
break;
case poDictionary:
if (format == TCL_ZLIB_FORMAT_GZIP) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a compression dictionary may not be set in the "
"gzip format", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
genericOptionError:
Tcl_AddErrorInfo(interp, "\n (in ");
Tcl_AddErrorInfo(interp, pushOptions[option]);
Tcl_AddErrorInfo(interp, " option)");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ZlibStreamCmd --
*
* Implementation of the commands returned by [zlib stream].
*
*----------------------------------------------------------------------
*/
static int
ZlibStreamCmd(
ClientData cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = cd;
int command, count, code;
Tcl_Obj *obj;
static const char *const cmds[] = {
"add", "checksum", "close", "eof", "finalize", "flush",
"fullflush", "get", "header", "put", "reset",
NULL
};
enum zlibStreamCommands {
zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush,
zs_fullflush, zs_get, zs_header, zs_put, zs_reset
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "option", 0,
&command) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum zlibStreamCommands) command) {
case zs_add: /* $strm add ?$flushopt? $data */
return ZlibStreamAddCmd(zstream, interp, objc, objv);
case zs_header: /* $strm header */
return ZlibStreamHeaderCmd(zstream, interp, objc, objv);
case zs_put: /* $strm put ?$flushopt? $data */
return ZlibStreamPutCmd(zstream, interp, objc, objv);
case zs_get: /* $strm get ?count? */
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?count?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2246 2247 2248 2249 2250 2251 2252 |
return TCL_OK;
case zs_checksum: /* $strm checksum */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
return TCL_OK;
case zs_checksum: /* $strm checksum */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibStreamChecksum(zstream)));
return TCL_OK;
case zs_reset: /* $strm reset */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return Tcl_ZlibStreamReset(zstream);
}
return TCL_OK;
}
static int
ZlibStreamAddCmd(
ClientData cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = cd;
int index, code, buffersize = -1, flush = -1, i;
Tcl_Obj *obj, *compDictObj = NULL;
static const char *const add_options[] = {
"-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL
};
enum addOptions {
ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush
};
for (i=2; i<objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum addOptions) index) {
case ao_flush: /* -flush */
if (flush > -1) {
flush = -2;
} else {
flush = Z_SYNC_FLUSH;
}
break;
case ao_fullflush: /* -fullflush */
if (flush > -1) {
flush = -2;
} else {
flush = Z_FULL_FLUSH;
}
break;
case ao_finalize: /* -finalize */
if (flush > -1) {
flush = -2;
} else {
flush = Z_FINISH;
}
break;
case ao_buffer: /* -buffer */
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-buffer\" option must be followed by integer "
"decompression buffersize", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"buffer size must be 1 to %d",
MAX_BUFFER_SIZE));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
return TCL_ERROR;
}
break;
case ao_dictionary:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-dictionary\" option must be followed by"
" compression dictionary bytes", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
compDictObj = objv[++i];
break;
}
if (flush == -2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-flush\", \"-fullflush\" and \"-finalize\" options"
" are mutually exclusive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
return TCL_ERROR;
}
}
if (flush == -1) {
flush = 0;
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
(void) Tcl_GetByteArrayFromObj(compDictObj, &len);
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) {
return TCL_ERROR;
}
/*
* Get such data out as we can (up to the requested length).
*/
TclNewObj(obj);
code = Tcl_ZlibStreamGet(zstream, obj, buffersize);
if (code == TCL_OK) {
Tcl_SetObjResult(interp, obj);
} else {
TclDecrRefCount(obj);
}
return code;
}
static int
ZlibStreamPutCmd(
ClientData cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = cd;
int index, flush = -1, i;
Tcl_Obj *compDictObj = NULL;
static const char *const put_options[] = {
"-dictionary", "-finalize", "-flush", "-fullflush", NULL
};
enum putOptions {
po_dictionary, po_finalize, po_flush, po_fullflush
};
for (i=2; i<objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum putOptions) index) {
case po_flush: /* -flush */
if (flush > -1) {
flush = -2;
} else {
flush = Z_SYNC_FLUSH;
}
break;
case po_fullflush: /* -fullflush */
if (flush > -1) {
flush = -2;
} else {
flush = Z_FULL_FLUSH;
}
break;
case po_finalize: /* -finalize */
if (flush > -1) {
flush = -2;
} else {
flush = Z_FINISH;
}
break;
case po_dictionary:
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-dictionary\" option must be followed by"
" compression dictionary bytes", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
compDictObj = objv[++i];
break;
}
if (flush == -2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-flush\", \"-fullflush\" and \"-finalize\" options"
" are mutually exclusive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
return TCL_ERROR;
}
}
if (flush == -1) {
flush = 0;
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
(void) Tcl_GetByteArrayFromObj(compDictObj, &len);
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush);
}
static int
ZlibStreamHeaderCmd(
ClientData cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
ZlibStreamHandle *zshPtr = cd;
Tcl_Obj *resultObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE
|| zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"only gunzip streams can produce header information", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
* Set of functions to support channel stacking.
*----------------------------------------------------------------------
*
* ZlibTransformClose --
|
| ︙ | ︙ | |||
2298 2299 2300 2301 2302 2303 2304 |
do {
cd->outStream.next_out = (Bytef *) cd->outBuffer;
cd->outStream.avail_out = (unsigned) cd->outAllocated;
e = deflate(&cd->outStream, Z_FINISH);
if (e != Z_OK && e != Z_STREAM_END) {
/* TODO: is this the right way to do errors on close? */
if (!TclInThreadExit()) {
| | | < | | | < | 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 |
do {
cd->outStream.next_out = (Bytef *) cd->outBuffer;
cd->outStream.avail_out = (unsigned) cd->outAllocated;
e = deflate(&cd->outStream, Z_FINISH);
if (e != Z_OK && e != Z_STREAM_END) {
/* TODO: is this the right way to do errors on close? */
if (!TclInThreadExit()) {
ConvertError(interp, e, cd->outStream.adler);
}
result = TCL_ERROR;
break;
}
if (cd->outStream.avail_out != (unsigned) cd->outAllocated) {
if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
cd->outAllocated - cd->outStream.avail_out) < 0) {
/* TODO: is this the right way to do errors on close?
* Note: when close is called from FinalizeIOSubsystem
* then interp may be NULL */
if (!TclInThreadExit() && interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error while finalizing file: %s",
Tcl_PosixError(interp)));
}
result = TCL_ERROR;
break;
}
}
} while (e != Z_STREAM_END);
e = deflateEnd(&cd->outStream);
|
| ︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 | * Length (cd->decompressed) == 0, toRead > 0 here. * * The zlib transform allows us to read at most one character from the * underlying channel to properly identify Z_STREAM_END without * reading over the border. */ | | | 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 | * Length (cd->decompressed) == 0, toRead > 0 here. * * The zlib transform allows us to read at most one character from the * underlying channel to properly identify Z_STREAM_END without * reading over the border. */ readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* * Three cases here: * 1. Got some data from the underlying channel (readBytes > 0) so * it should be fed through the decompression engine. * 2. Got an error (readBytes < 0) which we should report up except * for the case where we can convert it to a short read. |
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 |
int toWrite,
int *errorCodePtr)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverOutputProc *outProc =
Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent));
int e, produced;
if (cd->mode == TCL_ZLIB_STREAM_INFLATE) {
return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
errorCodePtr);
}
cd->outStream.next_in = (Bytef *) buf;
| > | 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 |
int toWrite,
int *errorCodePtr)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverOutputProc *outProc =
Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent));
int e, produced;
Tcl_Obj *errObj;
if (cd->mode == TCL_ZLIB_STREAM_INFLATE) {
return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
errorCodePtr);
}
cd->outStream.next_in = (Bytef *) buf;
|
| ︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 |
if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
*errorCodePtr = Tcl_GetErrno();
return -1;
}
}
} while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0);
| | > > | > > > > > | > | | < < < | 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 |
if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
*errorCodePtr = Tcl_GetErrno();
return -1;
}
}
} while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0);
if (e == Z_OK) {
return toWrite - cd->outStream.avail_in;
}
errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
Tcl_ListObjAppendElement(NULL, errObj,
ConvertErrorToList(e, cd->outStream.adler));
Tcl_ListObjAppendElement(NULL, errObj,
Tcl_NewStringObj(cd->outStream.msg, -1));
Tcl_SetChannelError(cd->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformSetOption --
*
|
| ︙ | ︙ | |||
2567 2568 2569 2570 2571 2572 2573 |
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverSetOptionProc *setOptionProc =
Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent));
| > | > > | < | < < < < < | | < < | | < < < | > | < | | | | | | < < | | < < | > | < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 |
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverSetOptionProc *setOptionProc =
Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent));
static const char *compressChanOptions = "dictionary flush";
static const char *gzipChanOptions = "flush";
static const char *decompressChanOptions = "dictionary limit";
static const char *gunzipChanOptions = "flush limit";
int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE);
if (optionName && (strcmp(optionName, "-dictionary") == 0)
&& (cd->format != TCL_ZLIB_FORMAT_GZIP)) {
Tcl_Obj *compDictObj;
int code;
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
(void) Tcl_GetByteArrayFromObj(compDictObj, NULL);
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
cd->compDictObj = compDictObj;
code = Z_OK;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
code = SetDeflateDictionary(&cd->outStream, compDictObj);
if (code != Z_OK) {
ConvertError(interp, code, cd->outStream.adler);
return TCL_ERROR;
}
} else if (cd->format == TCL_ZLIB_FORMAT_RAW) {
code = SetInflateDictionary(&cd->inStream, compDictObj);
if (code != Z_OK) {
ConvertError(interp, code, cd->inStream.adler);
return TCL_ERROR;
}
}
return TCL_OK;
}
if (haveFlushOpt) {
if (optionName && strcmp(optionName, "-flush") == 0) {
int flushType;
if (value[0] == 'f' && strcmp(value, "full") == 0) {
flushType = Z_FULL_FLUSH;
} else if (value[0] == 's' && strcmp(value, "sync") == 0) {
flushType = Z_SYNC_FLUSH;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown -flush type \"%s\": must be full or sync",
value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL);
return TCL_ERROR;
}
/*
* Try to actually do the flush now.
*/
cd->outStream.avail_in = 0;
while (1) {
int e;
cd->outStream.next_out = (Bytef *) cd->outBuffer;
cd->outStream.avail_out = cd->outAllocated;
e = deflate(&cd->outStream, flushType);
if (e == Z_BUF_ERROR) {
break;
} else if (e != Z_OK) {
ConvertError(interp, e, cd->outStream.adler);
return TCL_ERROR;
} else if (cd->outStream.avail_out == 0) {
break;
}
if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"problem flushing channel: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
return TCL_OK;
}
} else {
if (optionName && strcmp(optionName, "-limit") == 0) {
int newLimit;
if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) {
return TCL_ERROR;
} else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-limit must be between 1 and 65536", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL);
return TCL_ERROR;
}
}
}
if (setOptionProc == NULL) {
if (cd->format == TCL_ZLIB_FORMAT_GZIP) {
return Tcl_BadChannelOption(interp, optionName,
(cd->mode == TCL_ZLIB_STREAM_DEFLATE)
? gzipChanOptions : gunzipChanOptions);
} else {
return Tcl_BadChannelOption(interp, optionName,
(cd->mode == TCL_ZLIB_STREAM_DEFLATE)
? compressChanOptions : decompressChanOptions);
}
}
/*
* Pass all unknown options down, to deeper transforms and/or the base
* channel.
*/
|
| ︙ | ︙ | |||
2648 2649 2650 2651 2652 2653 2654 |
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverGetOptionProc *getOptionProc =
Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent));
| > > > | | 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 |
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
ZlibChannelData *cd = instanceData;
Tcl_DriverGetOptionProc *getOptionProc =
Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent));
static const char *compressChanOptions = "checksum dictionary";
static const char *gzipChanOptions = "checksum";
static const char *decompressChanOptions = "checksum dictionary limit";
static const char *gunzipChanOptions = "checksum header limit";
/*
* The "crc" option reports the current CRC (calculated with the Adler32
* or CRC32 algorithm according to the format) given the data that has
* been processed so far.
*/
|
| ︙ | ︙ | |||
2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 |
Tcl_DStringAppendElement(dsPtr, "-checksum");
Tcl_DStringAppendElement(dsPtr, buf);
} else {
Tcl_DStringAppend(dsPtr, buf, -1);
return TCL_OK;
}
}
/*
* The "header" option, which is only valid on inflating gzip channels,
* reports the header that has been read from the start of the stream.
*/
if ((cd->flags & IN_HEADER) && ((optionName == NULL) ||
(strcmp(optionName, "-header") == 0))) {
Tcl_Obj *tmpObj = Tcl_NewObj();
ExtractHeader(&cd->inHeader.header, tmpObj);
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-header");
Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj));
Tcl_DecrRefCount(tmpObj);
} else {
| > > > > > > > > > > > > > > > > > > > > > > < < < | > | > > > > > > > | 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 |
Tcl_DStringAppendElement(dsPtr, "-checksum");
Tcl_DStringAppendElement(dsPtr, buf);
} else {
Tcl_DStringAppend(dsPtr, buf, -1);
return TCL_OK;
}
}
if ((cd->format != TCL_ZLIB_FORMAT_GZIP) &&
(optionName == NULL || strcmp(optionName, "-dictionary") == 0)) {
/*
* Embedded NUL bytes are ok; they'll be C080-encoded.
*/
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-dictionary");
if (cd->compDictObj) {
Tcl_DStringAppendElement(dsPtr,
Tcl_GetString(cd->compDictObj));
} else {
Tcl_DStringAppendElement(dsPtr, "");
}
} else {
int len;
const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len);
Tcl_DStringAppend(dsPtr, str, len);
}
}
/*
* The "header" option, which is only valid on inflating gzip channels,
* reports the header that has been read from the start of the stream.
*/
if ((cd->flags & IN_HEADER) && ((optionName == NULL) ||
(strcmp(optionName, "-header") == 0))) {
Tcl_Obj *tmpObj = Tcl_NewObj();
ExtractHeader(&cd->inHeader.header, tmpObj);
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-header");
Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj));
Tcl_DecrRefCount(tmpObj);
} else {
TclDStringAppendObj(dsPtr, tmpObj);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
}
}
/*
* Now we do the standard processing of the stream we wrapped.
*/
if (getOptionProc) {
return getOptionProc(Tcl_GetChannelInstanceData(cd->parent),
interp, optionName, dsPtr);
}
if (optionName == NULL) {
return TCL_OK;
}
if (cd->format == TCL_ZLIB_FORMAT_GZIP) {
return Tcl_BadChannelOption(interp, optionName,
(cd->mode == TCL_ZLIB_STREAM_DEFLATE)
? gzipChanOptions : gunzipChanOptions);
} else {
return Tcl_BadChannelOption(interp, optionName,
(cd->mode == TCL_ZLIB_STREAM_DEFLATE)
? compressChanOptions : decompressChanOptions);
}
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformWatch, ZlibTransformEventHandler --
*
|
| ︙ | ︙ | |||
2856 2857 2858 2859 2860 2861 2862 2863 |
* readable. */
int format, /* One of the TCL_ZLIB_FORMAT_* values that
* indicates what compressed format to allow.
* TCL_ZLIB_FORMAT_AUTO is only supported for
* decompressing transforms. */
int level, /* What compression level to use. Ignored for
* decompressing transforms. */
Tcl_Channel channel, /* The channel to attach to. */
| > > | > > > > > < < | > > > > > > | 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 |
* readable. */
int format, /* One of the TCL_ZLIB_FORMAT_* values that
* indicates what compressed format to allow.
* TCL_ZLIB_FORMAT_AUTO is only supported for
* decompressing transforms. */
int level, /* What compression level to use. Ignored for
* decompressing transforms. */
int limit, /* The limit on the number of bytes to read
* ahead; always at least 1. */
Tcl_Channel channel, /* The channel to attach to. */
Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to
* use a default. Ignored if not compressing
* to produce gzip-format data. */
Tcl_Obj *compDictObj) /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
{
ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData));
Tcl_Channel chan;
int wbits = 0;
int e;
if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) {
Tcl_Panic("unknown mode: %d", mode);
}
memset(cd, 0, sizeof(ZlibChannelData));
cd->mode = mode;
cd->format = format;
cd->readAheadLimit = limit;
if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) {
if (mode == TCL_ZLIB_STREAM_DEFLATE) {
if (gzipHeaderDictPtr) {
cd->flags |= OUT_HEADER;
if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader,
NULL) != TCL_OK) {
goto error;
}
}
} else {
cd->flags |= IN_HEADER;
cd->inHeader.header.name = (Bytef *)
&cd->inHeader.nativeFilenameBuf;
cd->inHeader.header.name_max = MAXPATHLEN - 1;
cd->inHeader.header.comment = (Bytef *)
&cd->inHeader.nativeCommentBuf;
cd->inHeader.header.comm_max = MAX_COMMENT_LEN - 1;
}
}
if (compDictObj != NULL) {
cd->compDictObj = Tcl_DuplicateObj(compDictObj);
Tcl_IncrRefCount(cd->compDictObj);
Tcl_GetByteArrayFromObj(cd->compDictObj, NULL);
}
if (format == TCL_ZLIB_FORMAT_RAW) {
wbits = WBITS_RAW;
} else if (format == TCL_ZLIB_FORMAT_ZLIB) {
wbits = WBITS_ZLIB;
} else if (format == TCL_ZLIB_FORMAT_GZIP) {
wbits = WBITS_GZIP;
|
| ︙ | ︙ | |||
2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 |
cd->inBuffer = ckalloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
e = inflateGetHeader(&cd->inStream, &cd->inHeader.header);
if (e != Z_OK) {
goto error;
}
}
} else {
e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
if (e != Z_OK) {
goto error;
}
cd->outAllocated = DEFAULT_BUFFER_SIZE;
cd->outBuffer = ckalloc(cd->outAllocated);
if (cd->flags & OUT_HEADER) {
e = deflateSetHeader(&cd->outStream, &cd->outHeader.header);
if (e != Z_OK) {
goto error;
}
}
}
Tcl_DStringInit(&cd->decompressed);
chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
Tcl_GetChannelMode(channel), channel);
| > > > > > > > > > > > > > > | 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 |
cd->inBuffer = ckalloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
e = inflateGetHeader(&cd->inStream, &cd->inHeader.header);
if (e != Z_OK) {
goto error;
}
}
if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) {
e = SetInflateDictionary(&cd->inStream, cd->compDictObj);
if (e != Z_OK) {
goto error;
}
TclDecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
} else {
e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY);
if (e != Z_OK) {
goto error;
}
cd->outAllocated = DEFAULT_BUFFER_SIZE;
cd->outBuffer = ckalloc(cd->outAllocated);
if (cd->flags & OUT_HEADER) {
e = deflateSetHeader(&cd->outStream, &cd->outHeader.header);
if (e != Z_OK) {
goto error;
}
}
if (cd->compDictObj) {
e = SetDeflateDictionary(&cd->outStream, cd->compDictObj);
if (e != Z_OK) {
goto error;
}
}
}
Tcl_DStringInit(&cd->decompressed);
chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
Tcl_GetChannelMode(channel), channel);
|
| ︙ | ︙ | |||
2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 |
ckfree(cd->inBuffer);
inflateEnd(&cd->inStream);
}
if (cd->outBuffer) {
ckfree(cd->outBuffer);
deflateEnd(&cd->outStream);
}
ckfree(cd);
return NULL;
}
/*
*----------------------------------------------------------------------
*
| > > > | 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 |
ckfree(cd->inBuffer);
inflateEnd(&cd->inStream);
}
if (cd->outBuffer) {
ckfree(cd->outBuffer);
deflateEnd(&cd->outStream);
}
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
}
ckfree(cd);
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3018 3019 3020 3021 3022 3023 3024 |
} else /* have <= toRead */ {
/*
* There is just or not enough in the buffer to fully satisfy the
* caller, so take everything as best effort.
*/
memcpy(buf, Tcl_DStringValue(&cd->decompressed), have);
| | | 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 |
} else /* have <= toRead */ {
/*
* There is just or not enough in the buffer to fully satisfy the
* caller, so take everything as best effort.
*/
memcpy(buf, Tcl_DStringValue(&cd->decompressed), have);
TclDStringClear(&cd->decompressed);
return have;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 |
int n,
int flush,
int *errorCodePtr)
{
#define MAXBUF 1024
unsigned char buf[MAXBUF];
int e, written;
cd->inStream.next_in = (Bytef *) cd->inBuffer;
cd->inStream.avail_in = n;
while (1) {
cd->inStream.next_out = (Bytef *) buf;
cd->inStream.avail_out = MAXBUF;
e = inflate(&cd->inStream, flush);
/*
* avail_out is now the left over space in the output. Therefore
* "MAXBUF - avail_out" is the amount of bytes generated.
*/
written = MAXBUF - cd->inStream.avail_out;
| > > > > > > > > > > > > > | 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 |
int n,
int flush,
int *errorCodePtr)
{
#define MAXBUF 1024
unsigned char buf[MAXBUF];
int e, written;
Tcl_Obj *errObj;
cd->inStream.next_in = (Bytef *) cd->inBuffer;
cd->inStream.avail_in = n;
while (1) {
cd->inStream.next_out = (Bytef *) buf;
cd->inStream.avail_out = MAXBUF;
e = inflate(&cd->inStream, flush);
if (e == Z_NEED_DICT && cd->compDictObj) {
e = SetInflateDictionary(&cd->inStream, cd->compDictObj);
if (e == Z_OK) {
/*
* A repetition of Z_NEED_DICT is just an error.
*/
cd->inStream.next_out = (Bytef *) buf;
cd->inStream.avail_out = MAXBUF;
e = inflate(&cd->inStream, flush);
}
}
/*
* avail_out is now the left over space in the output. Therefore
* "MAXBUF - avail_out" is the amount of bytes generated.
*/
written = MAXBUF - cd->inStream.avail_out;
|
| ︙ | ︙ | |||
3090 3091 3092 3093 3094 3095 3096 |
* Just indicates that the zlib couldn't consume input/produce output,
* and is fixed by supplying more input.
*
* Otherwise, we've got errors and need to report to higher-up.
*/
if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
| < | < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 |
* Just indicates that the zlib couldn't consume input/produce output,
* and is fixed by supplying more input.
*
* Otherwise, we've got errors and need to report to higher-up.
*/
if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
goto handleError;
}
/*
* Check if the inflate stopped early.
*/
if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) {
return TCL_OK;
}
}
handleError:
errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
Tcl_ListObjAppendElement(NULL, errObj,
ConvertErrorToList(e, cd->inStream.adler));
Tcl_ListObjAppendElement(NULL, errObj,
Tcl_NewStringObj(cd->inStream.msg, -1));
Tcl_SetChannelError(cd->parent, errObj);
*errorCodePtr = EINVAL;
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
* Finally, the TclZlibInit function. Used to install the zlib API.
*----------------------------------------------------------------------
*/
int
TclZlibInit(
Tcl_Interp *interp)
{
Tcl_Config cfg[2];
/*
* This does two things. It creates a counter used in the creation of
* stream commands, and it creates the namespace that will contain those
* commands.
*/
Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}");
/*
* Create the public scripted interface to this file's functionality.
*/
Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0);
/*
* Store the underlying configuration information.
*
* TODO: Describe whether we're using the system version of the library or
* a compatibility version built into Tcl?
*/
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
* Formally provide the package as a Tcl built-in.
*/
return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
}
/*
*----------------------------------------------------------------------
* Stubs used when a suitable zlib installation was not found during
* configure.
*----------------------------------------------------------------------
*/
#else /* !HAVE_ZLIB */
int
Tcl_ZlibStreamInit(
Tcl_Interp *interp,
int mode,
int format,
int level,
Tcl_Obj *dictObj,
Tcl_ZlibStream *zshandle)
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
int
Tcl_ZlibStreamClose(
Tcl_ZlibStream zshandle)
|
| ︙ | ︙ | |||
3218 3219 3220 3221 3222 3223 3224 |
Tcl_ZlibDeflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int level,
Tcl_Obj *gzipHeaderDictObj)
{
| | | | 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 |
Tcl_ZlibDeflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int level,
Tcl_Obj *gzipHeaderDictObj)
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
return TCL_ERROR;
}
unsigned int
Tcl_ZlibCRC32(
unsigned int crc,
|
| ︙ | ︙ | |||
3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 |
Tcl_ZlibAdler32(
unsigned int adler,
const char *buf,
int len)
{
return 0;
}
#endif /* HAVE_ZLIB */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > | 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 |
Tcl_ZlibAdler32(
unsigned int adler,
const char *buf,
int len)
{
return 0;
}
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
/* Do nothing. */
}
#endif /* HAVE_ZLIB */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to library/dde/pkgIndex.tcl.
|
| | | | 1 2 3 4 5 6 7 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde]
} else {
package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde]
}
|
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # http.tcl -- # # Client-side HTTP for GET, POST, and HEAD commands. These routines can # be used in untrusted code that uses the Safesock security policy. # These procedures use a callback interface to avoid using vwait, which # is not defined in the safe base. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.6 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy.
# These procedures use a callback interface to avoid using vwait, which
# is not defined in the safe base.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.8.6
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
|
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
([info exists state(connection)] && ($state(connection) eq "close"))
} {
CloseSocket $state(sock) $token
}
if {[info exists state(after)]} {
after cancel $state(after)
}
| | > > | < | | | < < < | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
([info exists state(connection)] && ($state(connection) eq "close"))
} {
CloseSocket $state(sock) $token
}
if {[info exists state(after)]} {
after cancel $state(after)
}
if {[info exists state(-command)] && !$skipCB
&& ![info exists state(done-command-cb)]} {
set state(done-command-cb) yes
if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} {
set state(error) [list $err $errorInfo $errorCode]
set state(status) error
}
}
}
# http::CloseSocket -
#
# Close a socket and remove it from the persistent sockets table. If
# possible an http token is included here but when we are called from a
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 |
# The "http" is the protocol, the user is "jschmoe", the password is
# "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
# "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
#
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
| < | > > > > | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
# The "http" is the protocol, the user is "jschmoe", the password is
# "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
# "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
#
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded. This is only
# done if $state(-strict) is true (inherited from $::http::strict).
set URLmatcher {(?x) # this is _expanded_ syntax
^
(?: (\w+) : ) ? # <protocol scheme>
(?: //
(?:
(
[^@/\#?]+ # <userinfo part of authority>
) @
)?
( # <host part of authority>
[^/:\#?]+ | # host name or IPv4 address
\[ [^/\#?]+ \] # IPv6 address in square brackets
)
(?: : (\d+) )? # <port part of authority>
)?
( / [^\#]*)? # <path> (including query)
(?: \# (.*) )? # <fragment>
$
}
# Phase one: parse
if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
unset $token
return -code error "Unsupported URL: $url"
}
# Phase two: validate
set host [string trim $host {[]}]; # strip square brackets from IPv6 address
if {$host eq ""} {
# Caller has to provide a host name; we do not have a "default host"
# that would enable us to handle relative URLs.
unset $token
return -code error "Missing host part: $url"
# Note that we don't check the hostname for validity here; if it's
# invalid, we'll simply fail to resolve it later on.
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 |
}
} elseif {$state(state) eq "header"} {
if {[catch {gets $sock line} n]} {
return [Finish $token $n]
} elseif {$n == 0} {
# We have now read all headers
# We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
| | | 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
}
} elseif {$state(state) eq "header"} {
if {[catch {gets $sock line} n]} {
return [Finish $token $n]
} elseif {$n == 0} {
# We have now read all headers
# We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} {
return
}
set state(state) body
# If doing a HEAD, then we won't get any body
if {$state(-validate)} {
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
if {$http(-urlencoding) ne ""} {
set string [encoding convertto $http(-urlencoding) $string]
return [string map $formMap $string]
}
set converted [string map $formMap $string]
if {[string match "*\[\u0100-\uffff\]*" $converted]} {
| | | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
if {$http(-urlencoding) ne ""} {
set string [encoding convertto $http(-urlencoding) $string]
return [string map $formMap $string]
}
set converted [string map $formMap $string]
if {[string match "*\[\u0100-\uffff\]*" $converted]} {
regexp "\[\u0100-\uffff\]" $converted badChar
# Return this error message for maximum compatability... :^/
return -code error \
"can't read \"formMap($badChar)\": no such element in array"
}
return $converted
}
|
| ︙ | ︙ |
Changes to library/http/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded http 2.8.6 [list tclPkgSetup $dir http 2.8.6 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
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.0
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
#
# The environment variable TCLLIBPATH
#
# tcl_library, which is the directory containing this init.tcl script.
|
| ︙ | ︙ | |||
685 686 687 688 689 690 691 |
foreach var {PATH Path path} {
if {[info exists env($var)]} {
append path ";$env($var)"
}
}
| > > | | | | | | < | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
foreach var {PATH Path path} {
if {[info exists env($var)]} {
append path ";$env($var)"
}
}
foreach ext $execExtensions {
unset -nocomplain checked
foreach dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || ($dir eq "")} {
continue
}
set checked($dir) {}
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
}
return ""
|
| ︙ | ︙ |
Changes to library/msgcat/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | > | | > < < < < | < < < < < | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > | > > > > > | < > | | | < | | | > | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | < < < < < < < < < < < | | | | > > | > > > | > > > > < | | | < | | | > > > > > | | > > > | | > > | | > > > > > > > < < < < | < > > > > > | < | > > > > > > > > > > > > > > > > > > > > > > | < < < | < | < < < < < > > < < < < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.61 for msgcat 1.5.0.
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization. ##
## --------------------- ##
# Be 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
# 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
# PATH needs CR
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
echo "#! /bin/sh" >conf$$.sh
echo "exit 0" >>conf$$.sh
chmod +x conf$$.sh
if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
PATH_SEPARATOR=';'
else
PATH_SEPARATOR=:
fi
rm -f conf$$.sh
fi
# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
as_unset=unset
else
as_unset=false
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.)
as_nl='
'
IFS=" "" $as_nl"
# Find who we are. Look in the path if we contain no directory separator.
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
echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
{ (exit 1); exit 1; }
fi
# Work around bugs in pre-3.0 UWIN ksh.
for as_var in ENV MAIL MAILPATH
do ($as_unset $as_var) >/dev/null 2>&1 && $as_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) >/dev/null 2>&1 && $as_unset $as_var
fi
done
# Required to use basename.
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
as_basename=basename
else
as_basename=false
fi
# Name of the executable.
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
}
/^X\/\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
# CDPATH.
$as_unset CDPATH
if test "x$CONFIG_SHELL" = x; then
if (eval ":") 2>/dev/null; then
as_have_required=yes
else
as_have_required=no
fi
if test $as_have_required = yes && (eval ":
(as_func_return () {
(exit \$1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test \$exitcode = 0) || { (exit 1); exit 1; }
(
as_lineno_1=\$LINENO
as_lineno_2=\$LINENO
test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&
test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }
") 2> /dev/null; then
:
else
as_candidate_shells=
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=.
case $as_dir in
/*)
for as_base in sh bash ksh sh5; do
as_candidate_shells="$as_candidate_shells $as_dir/$as_base"
done;;
esac
done
IFS=$as_save_IFS
for as_shell in $as_candidate_shells $SHELL; do
# Try only shells that exist, to save several forks.
if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
{ ("$as_shell") 2> /dev/null <<\_ASEOF
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
:
_ASEOF
}; then
CONFIG_SHELL=$as_shell
as_have_required=yes
if { "$as_shell" 2> /dev/null <<\_ASEOF
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
:
(as_func_return () {
(exit $1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = "$1" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test $exitcode = 0) || { (exit 1); exit 1; }
(
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }
_ASEOF
}; then
break
fi
fi
done
if test "x$CONFIG_SHELL" != x; then
for as_var in BASH_ENV ENV
do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
done
export CONFIG_SHELL
exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}
fi
if test $as_have_required = no; then
echo This script requires a shell more modern than all the
echo shells that I found on your system. Please install a
echo modern shell, or manually run the script under such a
echo shell if you do have one.
{ (exit 1); exit 1; }
fi
fi
fi
(eval "as_func_return () {
(exit \$1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test \$exitcode = 0") || {
echo No shell found that supports shell functions.
echo Please tell autoconf@gnu.org about your system,
echo including any error possibly output before this
echo message
}
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
# 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 after each line using $LINENO; the second 'sed'
# does the real work. The second script uses 'N' to pair each
# line-number line with the line containing $LINENO, 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
# scripts with optimization help from Paolo Bonzini. Blame Lee
# E. McMahon (1931-1989) for sed's syntax. :-)
sed -n '
p
/[$]LINENO/=
' <$as_myself |
sed '
s/[$]LINENO.*/&-/
t lineno
b
:lineno
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
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; }; }
# 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 sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in
-n*)
case `echo 'x\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
*) ECHO_C='\c';;
esac;;
*)
ECHO_N='-n';;
esac
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir
fi
echo >conf$$.file
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 -p'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
as_ln_s='cp -p'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
as_mkdir_p=:
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
if test -x / >/dev/null 2>&1; then
as_test_x='test -x'
else
if ls -dL / >/dev/null 2>&1; then
as_ls_L_option=L
else
as_ls_L_option=
fi
as_test_x='
eval sh -c '\''
if test -d "$1"; then
test -d "$1/.";
else
case $1 in
-*)set "./$1";;
esac;
case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
???[sx]*):;;*)false;;esac;fi
'\'' sh
'
fi
as_executable_p=$as_test_x
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
exec 7<&0 </dev/null 6>&1
# Name of the host.
# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
# so uname gets run too.
ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
#
# 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}
# Identity of this package.
PACKAGE_NAME='msgcat'
PACKAGE_TARNAME='msgcat'
PACKAGE_VERSION='1.5.0'
PACKAGE_STRING='msgcat 1.5.0'
PACKAGE_BUGREPORT=''
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
datarootdir
datadir
sysconfdir
sharedstatedir
localstatedir
includedir
oldincludedir
docdir
infodir
htmldir
dvidir
pdfdir
psdir
libdir
localedir
mandir
DEFS
ECHO_C
ECHO_N
ECHO_T
LIBS
build_alias
host_alias
target_alias
LIBOBJS
LTLIBOBJS'
ac_subst_files=''
ac_precious_vars='build_alias
host_alias
target_alias'
# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
# The variables have the same names as the options, with
# dashes changed to underlines.
cache_file=/dev/null
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 302 303 304 |
x_libraries=NONE
# Installation directory options.
# These are left unexpanded so users can "make install exec_prefix=/foo"
# and all the variables that are supposed to be based on exec_prefix
# by default will actually change.
# Use braces instead of parens because sh, perl, etc. also accept them.
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
| > | > < > | > > > > > > | > | > | > > | > > | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
x_libraries=NONE
# Installation directory options.
# These are left unexpanded so users can "make install exec_prefix=/foo"
# and all the variables that are supposed to be based on exec_prefix
# by default will actually change.
# Use braces instead of parens because sh, perl, etc. also accept them.
# (The list follows the same order as the GNU Coding Standards.)
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
includedir='${prefix}/include'
oldincludedir='/usr/include'
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
ac_prev=
continue
fi
case $ac_option in
*=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
*) ac_optarg=yes ;;
esac
# Accept the important Cygnus configure options, so we can diagnose typos.
case $ac_dashdash$ac_option in
--)
ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
-bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
bindir=$ac_optarg ;;
-build | --build | --buil | --bui | --bu)
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
-cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
| --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
cache_file=$ac_optarg ;;
--config-cache | -C)
cache_file=config.cache ;;
| | | > > > | > > > | | | | > > > > > > > > > > | | < < < < | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 |
-cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
| --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
cache_file=$ac_optarg ;;
--config-cache | -C)
cache_file=config.cache ;;
-datadir | --datadir | --datadi | --datad)
ac_prev=datadir ;;
-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-\(.*\)'`
# 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 ;;
-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-\([^=]*\)'`
# 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=\$ac_optarg ;;
-exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
| --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
| --exec | --exe | --ex)
ac_prev=exec_prefix ;;
-exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
| --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
-help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
ac_init_help=short ;;
-host | --host | --hos | --ho)
ac_prev=host_alias ;;
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
-includedir | --includedir | --includedi | --included | --include \
| --includ | --inclu | --incl | --inc)
ac_prev=includedir ;;
-includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
| --includ=* | --inclu=* | --incl=* | --inc=*)
includedir=$ac_optarg ;;
| > > > > > > | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
-help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
ac_init_help=short ;;
-host | --host | --hos | --ho)
ac_prev=host_alias ;;
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
-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 ;;
-includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
| --includ=* | --inclu=* | --incl=* | --inc=*)
includedir=$ac_optarg ;;
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 427 428 |
-libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
| --libexe | --libex | --libe)
ac_prev=libexecdir ;;
-libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
| --libexe=* | --libex=* | --libe=*)
libexecdir=$ac_optarg ;;
-localstatedir | --localstatedir | --localstatedi | --localstated \
| > > > > > | < | < | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
-libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
| --libexe | --libex | --libe)
ac_prev=libexecdir ;;
-libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
| --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)
ac_prev=localstatedir ;;
-localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
| --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
localstatedir=$ac_optarg ;;
-mandir | --mandir | --mandi | --mand | --man | --ma | --m)
ac_prev=mandir ;;
-mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
mandir=$ac_optarg ;;
|
| ︙ | ︙ | |||
491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
| --program-transform-nam=* | --program-transform-na=* \
| --program-transform-n=* | --program-transform-=* \
| --program-transform=* | --program-transfor=* \
| --program-transfo=* | --program-transf=* \
| --program-trans=* | --program-tran=* \
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
| > > > > > > > > > > | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 |
| --program-transform-nam=* | --program-transform-na=* \
| --program-transform-n=* | --program-transform-=* \
| --program-transform=* | --program-transfor=* \
| --program-transfo=* | --program-transf=* \
| --program-trans=* | --program-tran=* \
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
-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 ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
| | | < < < < | | | | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid package name: $ac_package" >&2
{ (exit 1); exit 1; }; }
ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
eval with_$ac_package=\$ac_optarg ;;
-without-* | --without-*)
ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid package name: $ac_package" >&2
{ (exit 1); exit 1; }; }
ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
eval with_$ac_package=no ;;
--x)
# Obsolete; use --with-x.
with_x=yes ;;
-x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
| --x-incl | --x-inc | --x-in | --x-i)
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
*=*)
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; }; }
| < | | | > > > | | | < < < < < < < < < < | | < | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 |
*=*)
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; }; }
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
echo "$as_me: WARNING: you should use --build, --host, --target" >&2
expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
echo "$as_me: WARNING: invalid host type: $ac_option" >&2
: ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
;;
esac
done
if test -n "$ac_prev"; then
ac_option=--`echo $ac_prev | sed 's/_/-/g'`
{ echo "$as_me: error: missing argument to $ac_option" >&2
{ (exit 1); exit 1; }; }
fi
# Be sure to have absolute directory names.
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=\$$ac_var
case $ac_val in
[\\/$]* | ?:[\\/]* ) continue;;
NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
esac
{ echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
{ (exit 1); exit 1; }; }
done
# There might be people who depend on the old broken behavior: `$host'
# used to hold the argument of --host etc.
# FIXME: To remove some day.
build=$build_alias
host=$host_alias
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 666 667 668 669 | fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes | > > > > > > > > > > | | | < | > > > | > > > | > > > | > > > | | | | < < < | | < < | > > > > > | < > | | | | | | | | | | | > | < < < < > > | > | > > > > > | > < | | > > | | > > > > | | | > > | < | < | < | | > | | | < | < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | | | | | | | < < | < < | | | | | > | | | < | | > | > | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
fi
ac_tool_prefix=
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 .` ||
{ echo "$as_me: error: Working directory cannot be determined" >&2
{ (exit 1); exit 1; }; }
test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
{ echo "$as_me: error: pwd does not report name of working directory" >&2
{ (exit 1); exit 1; }; }
# 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 the parent directory.
ac_confdir=`$as_dirname -- "$0" ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$0" : 'X\(//\)[^/]' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$0" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
srcdir=$ac_confdir
if test ! -r "$srcdir/$ac_unique_file"; then
srcdir=..
fi
else
ac_srcdir_defaulted=no
fi
if test ! -r "$srcdir/$ac_unique_file"; then
test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
{ echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
{ (exit 1); exit 1; }; }
fi
ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
ac_abs_confdir=`(
cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2
{ (exit 1); exit 1; }; }
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.
#
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 msgcat 1.5.0 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE. See below for descriptions of some of the useful variables.
Defaults for the options are specified in brackets.
Configuration:
-h, --help display this help and exit
--help=short display options specific to this package
--help=recursive display the short help of all the included packages
-V, --version display version information and exit
-q, --quiet, --silent do not print \`checking...' messages
--cache-file=FILE cache test results in FILE [disabled]
-C, --config-cache alias for \`--cache-file=config.cache'
-n, --no-create do not create output files
--srcdir=DIR find the sources in DIR [configure dir or \`..']
Installation directories:
--prefix=PREFIX install architecture-independent files in PREFIX
[$ac_default_prefix]
--exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
[PREFIX]
By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.
For better control, use the options below.
Fine tuning of the installation directories:
--bindir=DIR user executables [EPREFIX/bin]
--sbindir=DIR system admin executables [EPREFIX/sbin]
--libexecdir=DIR program executables [EPREFIX/libexec]
--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/msgcat]
--htmldir=DIR html documentation [DOCDIR]
--dvidir=DIR dvi documentation [DOCDIR]
--pdfdir=DIR pdf documentation [DOCDIR]
--psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
_ACEOF
fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of msgcat 1.5.0:";;
esac
cat <<\_ACEOF
_ACEOF
ac_status=$?
fi
if test "$ac_init_help" = "recursive"; then
# If there are subdirs, report their specific --help.
for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
test -d "$ac_dir" || continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`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
.) # We are building in place.
ac_srcdir=.
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
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
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 || ac_status=$?
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
msgcat configure 1.5.0
generated by GNU Autoconf 2.61
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
2002, 2003, 2004, 2005, 2006 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
fi
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 msgcat $as_me 1.5.0, which was
generated by GNU Autoconf 2.61. Invocation command line was
$ $0 $@
_ACEOF
exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
## Platform. ##
## --------- ##
hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
uname -m = `(uname -m) 2>/dev/null || echo unknown`
uname -r = `(uname -r) 2>/dev/null || echo unknown`
uname -s = `(uname -s) 2>/dev/null || echo unknown`
uname -v = `(uname -v) 2>/dev/null || echo unknown`
/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
/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`
_ASUNAME
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
echo "PATH: $as_dir"
done
IFS=$as_save_IFS
} >&5
cat >&5 <<_ACEOF
## ----------- ##
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 | # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= | < | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 |
# Strip out --no-create and --no-recursion so they do not pile up.
# Strip out --silent because we don't want to record it for future runs.
# Also quote any args containing shell meta-characters.
# Make two passes to allow for proper duplicate-argument suppression.
ac_configure_args=
ac_configure_args0=
ac_configure_args1=
ac_must_keep_next=false
for ac_pass in 1 2
do
for ac_arg
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
2)
ac_configure_args1="$ac_configure_args1 '$ac_arg'"
if test $ac_must_keep_next = true; then
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
case "$ac_configure_args0 " in
"$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
esac
;;
-* ) ac_must_keep_next=true ;;
esac
fi
| | < < | | > > > > | > > > > > > > > > > | | | | | < | | < > > | > > > | | | | | > > > | | | | | | < < | 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
case "$ac_configure_args0 " in
"$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
esac
;;
-* ) ac_must_keep_next=true ;;
esac
fi
ac_configure_args="$ac_configure_args '$ac_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; }
# 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: 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
## ---------------- ##
## 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_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
*) $as_unset $ac_var ;;
esac ;;
esac
done
(set) 2>&1 |
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"
;; #(
*)
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
cat <<\_ASBOX
## ----------------- ##
## Output variables. ##
## ----------------- ##
_ASBOX
echo
for ac_var in $ac_subst_vars
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
echo "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
cat <<\_ASBOX
## ------------------- ##
## File substitutions. ##
## ------------------- ##
_ASBOX
echo
for ac_var in $ac_subst_files
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
echo "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
echo
cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
echo "$as_me: caught signal $ac_signal"
echo "$as_me: exit $exit_status"
} >&5
rm -f core *.core core.conftest.* &&
rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
' 0
for ac_signal in 1 2 13 15; do
trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -f -r conftest* confdefs.h
# Predefined preprocessor variables.
cat >>confdefs.h <<_ACEOF
#define PACKAGE_NAME "$PACKAGE_NAME"
_ACEOF
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 | cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer explicitly selected file to automatically selected ones. | | > | | | > | | | | > | | | < | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 |
cat >>confdefs.h <<_ACEOF
#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
_ACEOF
# Let the site file select an alternate cache file if it wants to.
# Prefer explicitly selected file to automatically selected ones.
if test -n "$CONFIG_SITE"; then
set x "$CONFIG_SITE"
elif test "x$prefix" != xNONE; then
set x "$prefix/share/config.site" "$prefix/etc/config.site"
else
set x "$ac_default_prefix/share/config.site" \
"$ac_default_prefix/etc/config.site"
fi
shift
for ac_site_file
do
if test -r "$ac_site_file"; then
{ echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
echo "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
. "$ac_site_file"
fi
done
if test -r "$cache_file"; then
# Some versions of bash will fail to source /dev/null (special
# files actually), so we avoid doing that.
if test -f "$cache_file"; then
{ echo "$as_me:$LINENO: loading cache $cache_file" >&5
echo "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
[\\/]* | ?:[\\/]* ) . "$cache_file";;
*) . "./$cache_file";;
esac
fi
else
{ echo "$as_me:$LINENO: creating cache $cache_file" >&5
echo "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in $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
case $ac_old_set,$ac_new_set in
set,)
{ echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
ac_cache_corrupted=: ;;
,set)
{ echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 |
echo "$as_me: current value: $ac_new_val" >&2;}
ac_cache_corrupted=:
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
| < | > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > > > > | | | | < | | > | > | | | | | | > > > | < < < < < < < < < < < < < < < | | | | | < > | | | | | > > > > > > | < < < < < < < < > > | < > | < | > | | | 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 |
echo "$as_me: current value: $ac_new_val" >&2;}
ac_cache_corrupted=:
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
*\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
*) ac_arg=$ac_var=$ac_new_val ;;
esac
case " $ac_configure_args " in
*" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
*) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
esac
fi
done
if $ac_cache_corrupted; then
{ echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
echo "$as_me: error: changes in the environment can compromise the build" >&2;}
{ { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
{ (exit 1); exit 1; }; }
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
ac_config_files="$ac_config_files Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs, see configure's option --config-cache.
# It is not useful on other systems. If it contains results you don't
# want to keep, you may remove or edit it.
#
# config.status only pays attention to the cache file if you give it
# the --recheck option to rerun configure.
#
# `ac_cv_env_foo' variables (set or unset) will be overridden when
# loading this file, other *unset* `ac_cv_foo' will be assigned the
# following values.
_ACEOF
# The following way of writing the cache mishandles newlines in values,
# but we know of no workaround that is simple, portable, and efficient.
# So, 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_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
*) $as_unset $ac_var ;;
esac ;;
esac
done
(set) 2>&1 |
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 "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
t end
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 "$as_me:$LINENO: updating cache $cache_file" >&5
echo "$as_me: updating cache $cache_file" >&6;}
cat confcache >$cache_file
else
{ echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5
echo "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
# 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 branch to the quote section. Otherwise,
# look for a macro that doesn't take arguments.
ac_script='
t clear
:clear
s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
t quote
s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g
t quote
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=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
# 1. Remove the extension, and $U if already installed.
ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
ac_i=`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.
ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"
ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs
LTLIBOBJS=$ac_ltlibobjs
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## | | > < < < < | < < < < < | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > | > > > > > | < > | | | < | | | > | | | | | | | | < | | | | > > > > | > > | > | > > > > > > > > > | > > > > > > > | > > > > > | | > > > > > > > > > > > > > > > > > > > | > > | > > < | < < < < < < < < < < < | | | | > > | > > > | > > > > < | | | < | < | | | > > > > > | | > > > | | > > | | > > > > > > > < < < < | < > > > > > | < | > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < | | < < < < < < < < | | | < | > | > | < < < < < | < < < < < < < < | < > | | | | > > | | | | < < < < < < | | < < < < < < < < < | | | < < < < | | | > | > > | | | | > > > > > > > > > > > | < | > > | | > > > | > > < | | | < | < < < | | | > | | | > > > > | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > < < < < < | < < < < | | | > > > | > > > > > > | > > > | > > > > > | > > > > > > | > | < > > > > > > > > > | | > > > > > > > > > > > > > > > > > | | < | | < < | | | > > > | | > | < < < | > | < < < < < < | < | < > | | | | > | > > > > > > > > > > > > > > > > > | | > > > > > | > > > | < < < < < | < | < < < < | > < | | < | > > > | > > > | > > > | > > > | < | | | > > | | > > > > | | < | > > > | > > > | > > > | > > > | > | | | < | > > | | > > > > | | | > > | < | < | < | | > | | | < | < < < < < < < < < < < < < < < < < < < < < < < | | | < < | > > > > | > | < > > > | < < < < > | | < < < < < < < < < < < < < < < | < < > > | > > | | | < < | | > > | < | > | | < | < | < < < < < < | < > > > > | > | | | | | | | > > | > > > > > > > | | | | > | > | | | > | < < | 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 |
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
## --------------------- ##
## 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
# 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
# PATH needs CR
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
echo "#! /bin/sh" >conf$$.sh
echo "exit 0" >>conf$$.sh
chmod +x conf$$.sh
if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
PATH_SEPARATOR=';'
else
PATH_SEPARATOR=:
fi
rm -f conf$$.sh
fi
# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
as_unset=unset
else
as_unset=false
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.)
as_nl='
'
IFS=" "" $as_nl"
# Find who we are. Look in the path if we contain no directory separator.
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
echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
{ (exit 1); exit 1; }
fi
# Work around bugs in pre-3.0 UWIN ksh.
for as_var in ENV MAIL MAILPATH
do ($as_unset $as_var) >/dev/null 2>&1 && $as_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) >/dev/null 2>&1 && $as_unset $as_var
fi
done
# Required to use basename.
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
as_basename=basename
else
as_basename=false
fi
# Name of the executable.
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
}
/^X\/\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
# CDPATH.
$as_unset CDPATH
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
# 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 after each line using $LINENO; the second 'sed'
# does the real work. The second script uses 'N' to pair each
# line-number line with the line containing $LINENO, 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
# scripts with optimization help from Paolo Bonzini. Blame Lee
# E. McMahon (1931-1989) for sed's syntax. :-)
sed -n '
p
/[$]LINENO/=
' <$as_myself |
sed '
s/[$]LINENO.*/&-/
t lineno
b
:lineno
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
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; }; }
# 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 sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in
-n*)
case `echo 'x\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
*) ECHO_C='\c';;
esac;;
*)
ECHO_N='-n';;
esac
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir
fi
echo >conf$$.file
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 -p'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
as_ln_s='cp -p'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
as_mkdir_p=:
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
if test -x / >/dev/null 2>&1; then
as_test_x='test -x'
else
if ls -dL / >/dev/null 2>&1; then
as_ls_L_option=L
else
as_ls_L_option=
fi
as_test_x='
eval sh -c '\''
if test -d "$1"; then
test -d "$1/.";
else
case $1 in
-*)set "./$1";;
esac;
case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
???[sx]*):;;*)false;;esac;fi
'\'' sh
'
fi
as_executable_p=$as_test_x
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
exec 6>&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.
ac_log="
This file was extended by msgcat $as_me 1.5.0, which was
generated by GNU Autoconf 2.61. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
CONFIG_LINKS = $CONFIG_LINKS
CONFIG_COMMANDS = $CONFIG_COMMANDS
$ $0 $@
on `(hostname || uname -n) 2>/dev/null | sed 1q`
"
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
# Files that config.status was made for.
config_files="$ac_config_files"
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
ac_cs_usage="\
\`$as_me' instantiates files from templates according to the
current configuration.
Usage: $0 [OPTIONS] [FILE]...
-h, --help print this help, then exit
-V, --version print version number and configuration settings, then exit
-q, --quiet do not print progress messages
-d, --debug don't remove temporary files
--recheck update $as_me by reconfiguring in the same conditions
--file=FILE[:TEMPLATE]
instantiate the configuration file FILE
Configuration files:
$config_files
Report bugs to <bug-autoconf@gnu.org>."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
msgcat config.status 1.5.0
configured by $0, generated by GNU Autoconf 2.61,
with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
Copyright (C) 2006 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
ac_pwd='$ac_pwd'
srcdir='$srcdir'
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default
# value. By we need to know if files were specified by the user.
ac_need_defaults=:
while test $# != 0
do
case $1 in
--*=*)
ac_option=`expr "X$1" : 'X\([^=]*\)='`
ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
ac_shift=:
;;
*)
ac_option=$1
ac_optarg=$2
ac_shift=shift
;;
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
echo "$ac_cs_version"; exit ;;
--debug | --debu | --deb | --de | --d | -d )
debug=: ;;
--file | --fil | --fi | --f )
$ac_shift
CONFIG_FILES="$CONFIG_FILES $ac_optarg"
ac_need_defaults=false;;
--he | --h | --help | --hel | -h )
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: error: unrecognized option: $1
Try \`$0 --help' for more information." >&2
{ (exit 1); exit 1; }; } ;;
*) ac_config_targets="$ac_config_targets $1"
ac_need_defaults=false ;;
esac
shift
done
ac_configure_extra_args=
if $ac_cs_silent; then
exec 6>/dev/null
ac_configure_extra_args="$ac_configure_extra_args --silent"
fi
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
if \$ac_cs_recheck; then
echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
CONFIG_SHELL=$SHELL
export CONFIG_SHELL
exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
fi
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
exec 5>>config.log
{
echo
sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
echo "$ac_log"
} >&5
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# Handling of arguments.
for ac_config_target in $ac_config_targets
do
case $ac_config_target in
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
*) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
{ (exit 1); exit 1; }; };;
esac
done
# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used. Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
fi
# Have a temporary directory for convenience. Make it in the build tree
# simply because there is no reason against having it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# 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 ||
{
tmp=
trap 'exit_status=$?
{ test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status
' 0
trap '{ (exit 1); exit 1; }' 1 2 13 15
}
# Create a (secure) tmp directory for tmp files.
{
tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
test -n "$tmp" && test -d "$tmp"
} ||
{
tmp=./conf$$-$RANDOM
(umask 077 && mkdir "$tmp")
} ||
{
echo "$me: cannot create a temporary directory in ." >&2
{ (exit 1); exit 1; }
}
#
# Set up the sed scripts for 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
_ACEOF
ac_delim='%!_!# '
for ac_last_try in false false false false false :; do
cat >conf$$subs.sed <<_ACEOF
SHELL!$SHELL$ac_delim
PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim
PACKAGE_NAME!$PACKAGE_NAME$ac_delim
PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim
PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim
PACKAGE_STRING!$PACKAGE_STRING$ac_delim
PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim
exec_prefix!$exec_prefix$ac_delim
prefix!$prefix$ac_delim
program_transform_name!$program_transform_name$ac_delim
bindir!$bindir$ac_delim
sbindir!$sbindir$ac_delim
libexecdir!$libexecdir$ac_delim
datarootdir!$datarootdir$ac_delim
datadir!$datadir$ac_delim
sysconfdir!$sysconfdir$ac_delim
sharedstatedir!$sharedstatedir$ac_delim
localstatedir!$localstatedir$ac_delim
includedir!$includedir$ac_delim
oldincludedir!$oldincludedir$ac_delim
docdir!$docdir$ac_delim
infodir!$infodir$ac_delim
htmldir!$htmldir$ac_delim
dvidir!$dvidir$ac_delim
pdfdir!$pdfdir$ac_delim
psdir!$psdir$ac_delim
libdir!$libdir$ac_delim
localedir!$localedir$ac_delim
mandir!$mandir$ac_delim
DEFS!$DEFS$ac_delim
ECHO_C!$ECHO_C$ac_delim
ECHO_N!$ECHO_N$ac_delim
ECHO_T!$ECHO_T$ac_delim
LIBS!$LIBS$ac_delim
build_alias!$build_alias$ac_delim
host_alias!$host_alias$ac_delim
target_alias!$target_alias$ac_delim
LIBOBJS!$LIBOBJS$ac_delim
LTLIBOBJS!$LTLIBOBJS$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 39; then
break
elif $ac_last_try; then
{ { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}
{ (exit 1); exit 1; }; }
else
ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
fi
done
ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`
if test -n "$ac_eof"; then
ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`
ac_eof=`expr $ac_eof + 1`
fi
cat >>$CONFIG_STATUS <<_ACEOF
cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end
_ACEOF
sed '
s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g
s/^/s,@/; s/!/@,|#_!!_#|/
:n
t n
s/'"$ac_delim"'$/,g/; t
s/$/\\/; p
N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n
' >>$CONFIG_STATUS <conf$$subs.sed
rm -f conf$$subs.sed
cat >>$CONFIG_STATUS <<_ACEOF
:end
s/|#_!!_#|//g
CEOF$ac_eof
_ACEOF
# 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
cat >>$CONFIG_STATUS <<\_ACEOF
fi # test -n "$CONFIG_FILES"
for ac_tag in :F $CONFIG_FILES
do
case $ac_tag in
:[FHLC]) ac_mode=$ac_tag; continue;;
esac
case $ac_mode$ac_tag in
:[FHL]*:*);;
:L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5
echo "$as_me: error: Invalid tag $ac_tag." >&2;}
{ (exit 1); exit 1; }; };;
:[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
case $ac_mode in
:L) ac_source=$1;;
:[FH])
ac_file_inputs=
for ac_f
do
case $ac_f in
-) ac_f="$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 ||
{ { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5
echo "$as_me: error: cannot find input file: $ac_f" >&2;}
{ (exit 1); exit 1; }; };;
esac
ac_file_inputs="$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 "`IFS=:
echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."
if test x"$ac_file" != x-; then
configure_input="$ac_file. $configure_input"
{ echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
fi
case $ac_tag in
*:-:* | *:-) cat >"$tmp/stdin";;
esac
;;
esac
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'`
{ as_dir="$ac_dir"
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`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 ||
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" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5
echo "$as_me: error: cannot create directory $as_dir" >&2;}
{ (exit 1); exit 1; }; }; }
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`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
.) # We are building in place.
ac_srcdir=.
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
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
case $ac_mode in
:F)
#
# CONFIG_FILE
#
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# 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=
case `sed -n '/datarootdir/ {
p
q
}
/@datadir@/p
/@docdir@/p
/@infodir@/p
/@localedir@/p
/@mandir@/p
' $ac_file_inputs` in
*datarootdir*) ac_datarootdir_seen=yes;;
*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
{ echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
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
# 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
sed "$ac_vpsub
$extrasub
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
:t
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
s&@configure_input@&$configure_input&;t t
s&@top_builddir@&$ac_top_builddir_sub&;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
" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&
{ echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined." >&5
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 "$tmp/stdin"
case $ac_file in
-) cat "$tmp/out"; rm -f "$tmp/out";;
*) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;
esac
;;
esac
done # for ac_tag
{ (exit 0); exit 0; }
_ACEOF
chmod +x $CONFIG_STATUS
ac_clean_files=$ac_clean_files_save
|
| ︙ | ︙ |
Changes to library/msgcat/configure.in.
|
| | | 1 2 | AC_INIT([msgcat], [1.5.0]) AC_OUTPUT([Makefile]) |
Changes to library/msgcat/doc/AddErrInfo.3.
| ︙ | ︙ | |||
103 104 105 106 107 108 109 | \fB\-errorcode\fR, and \fB\-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB\-code\fR and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | \fB\-errorcode\fR, and \fB\-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB\-code\fR and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting any entries in it, without the need to check for a shared value. As with any \fBTcl_Obj\fR with reference count of zero, it is up to the caller to arrange for its disposal with \fBTcl_DecrRefCount\fR or to a reference to it via \fBTcl_IncrRefCount\fR (or one of the many functions that call that, notably including \fBTcl_SetObjResult\fR and \fBTcl_SetVar2Ex\fR). .PP A typical usage for \fBTcl_GetReturnOptions\fR is to |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the | | | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the \fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR built up by the caller. \fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .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. .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full |
| ︙ | ︙ | |||
305 306 307 308 309 310 311 | \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), tclvars(n) .SH KEYWORDS | | | 305 306 307 308 309 310 311 312 | \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), tclvars(n) .SH KEYWORDS error, value, value result, stack, trace, variable |
Changes to library/msgcat/doc/BoolObj.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP int *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS | | | 88 89 90 91 92 93 94 95 | while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS boolean, value |
Changes to library/msgcat/doc/ByteArrObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 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. '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | '\" '\" Copyright (c) 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. '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) .sp void \fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) .sp unsigned char * \fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. .AP int length in The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array value, it will be converted to one. .AP int *lengthPtr out If non-NULL, filled with the length of the array of bytes in the value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl byte-array values from C code. Byte-array values are typically used to hold the results of binary IO operations or data structures created with the \fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a string. Conceptually, a string is an array of Unicode characters, while a byte-array is an array of 8-bit quantities with no implicit meaning. Accessor functions are provided to get the string representation of a byte-array or to convert an arbitrary value to a byte-array. Obtaining the string representation of a byte-array value (by calling \fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the UTF-8 characters in the string representation. .PP \fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will create a new value of byte-array type or modify an existing value to have a byte-array type. Both of these procedures set the value's type to be byte-array and set the value's internal representation to a copy of the array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a pointer to a newly allocated value with a reference count of zero. \fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if the value is not already a byte-array value, frees any old internal representation. If \fIbytes\fR is NULL then the new byte array contains arbitrary values. .PP \fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and returns a pointer to the value's new internal representation as an array of bytes. The length of this array is stored in \fIlengthPtr\fR if \fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by the value and should not be freed. The contents of the array may be modified by the caller only if the value is not shared and the caller invalidates the string representation. .PP \fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type and changes the length of the value's internal representation as an array of bytes. If \fIlength\fR is greater than the space currently allocated for the array, the array is reallocated to the new length; the newly allocated bytes at the end of the array have arbitrary values. If \fIlength\fR is less than the space currently allocated for the array, the length of array is reduced to the new length. The return value is a pointer to the value's new array of bytes. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS value, binary data, byte array, utf, unicode, internationalization |
Changes to library/msgcat/doc/CrtChannel.3.
| ︙ | ︙ | |||
246 247 248 249 250 251 252 | \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or | | | | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or output. The \fIsize\fR argument should be between one and one million, allowing buffers of one byte to one million bytes. If \fIsize\fR is outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have occurred on the channel. Channel drivers are responsible for invoking this function whenever the channel handlers need to be called for the |
| ︙ | ︙ | |||
842 843 844 845 846 847 848 | (optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP It always returns \fBTCL_ERROR\fR .PP | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
(optional) interpreter. It is used by channel drivers when
an invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
the generic options error message string.
.PP
It always returns \fBTCL_ERROR\fR
.PP
An error message is generated in \fIinterp\fR's result value to
indicate that a command was invoked with a bad option.
The message has the form
.CS
bad option "blah": should be one of
<...generic options...>+<...specific options...>
.CE
so you get for instance:
|
| ︙ | ︙ |
Changes to library/msgcat/doc/CrtCommand.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of | | | | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of argument strings instead of values. The value-based command procedures registered by \fBTcl_CreateObjCommand\fR can execute significantly faster than the string-based command procedures defined by \fBTcl_CreateCommand\fR. This is because they take Tcl values as arguments and those values can retain an internal representation that can be manipulated more efficiently. Also, Tcl's interpreter now uses values internally. In order to invoke a string-based command procedure registered by \fBTcl_CreateCommand\fR, it must generate and fetch a string representation from each argument value before the call. New commands should be defined using \fBTcl_CreateObjCommand\fR. We support \fBTcl_CreateCommand\fR for backwards compatibility. .PP The procedures \fBTcl_DeleteCommand\fR, \fBTcl_GetCommandInfo\fR, and \fBTcl_SetCommandInfo\fR are used in conjunction with \fBTcl_CreateCommand\fR. .PP |
| ︙ | ︙ |
Changes to library/msgcat/doc/CrtMathFnc.3.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH "NOTICE OF EVENTUAL DEPRECATION" .PP The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions are rendered somewhat obsolete by the ability to create functions for expressions by placing commands in the \fBtcl::mathfunc\fR namespace, as described in the \fBmathfunc\fR manual page; the API described on this page is not expected to be maintained indefinitely. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp |
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP \fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all the math functions defined in the interpreter whose name matches \fIpattern\fR. The returned value has a reference count of zero. .SH "SEE ALSO" expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) .SH KEYWORDS expression, mathematical function |
Changes to library/msgcat/doc/CrtObjCmd.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in Value containing the name of a Tcl command. .BE .SH DESCRIPTION .PP \fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIname\fR is invoked as a Tcl command (e.g., via a call to \fBTcl_EvalObjEx\fR) |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | .CE .PP When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the | | | | | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | .CE .PP When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the arguments to the command, \fIobjc\fR giving the number of argument values (including the command name) and \fIobjv\fR giving the values of the arguments. The \fIobjv\fR array will contain \fIobjc\fR values, pointing to the argument values. Unlike \fIargv\fR[\fIargv\fR] used in a string-based command procedure, \fIobjv\fR[\fIobjc\fR] will not contain NULL. .PP Additionally, when \fIproc\fR is invoked, it must not modify the contents of the \fIobjv\fR array by assigning new pointer values to any element of the array (for example, \fIobjv\fR[\fB2\fR] = \fBNULL\fR) because this will cause memory to be lost and the runtime stack to be corrupted. The \fBconst\fR in the declaration of \fIobjv\fR will cause ANSI-compliant compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual value argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, if \fIproc\fR needs to return a non-empty result, it can call \fBTcl_SetObjResult\fR to set the interpreter's result. In the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR this gives an error message. Before invoking a command procedure, \fBTcl_EvalObjEx\fR sets interpreter's result to point to a value representing an empty string, so simple commands can return an empty result by doing nothing at all. .PP The contents of the \fIobjv\fR array belong to Tcl and are not guaranteed to persist once \fIproc\fR returns: \fIproc\fR should not modify them. Call \fBTcl_SetObjResult\fR if you want to return something from the \fIobjv\fR array. |
| ︙ | ︙ | |||
221 222 223 224 225 226 227 | It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; | | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 | It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; they hold information about the value-based command procedure that the Tcl interpreter calls to implement the command. The fields \fIproc\fR and \fIclientData\fR hold information about the string-based command procedure that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. The field \fIdeleteData\fR is the ClientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. The field \fInamespacePtr\fR holds a pointer to the Tcl_Namespace that contains the command. .PP |
| ︙ | ︙ | |||
286 287 288 289 290 291 292 | owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name of a command from a command token. The name, including all namespace prefixes, | | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name of a command from a command token. The name, including all namespace prefixes, is appended to the value specified by \fIobjPtr\fR. .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS bind, command, create, delete, namespace, value |
Changes to library/msgcat/doc/CrtSlave.3.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in | | | | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in Count of additional value arguments to pass to the aliased command. .AP Tcl_Obj **objv in Vector of Tcl_Obj structures, the additional value arguments to pass to the aliased command. This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target command is defined for an alias. .AP "const char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. .AP int *argcPtr out Pointer to location to store count of additional arguments to be passed to the alias. The location is in storage owned by the caller. .AP "const char" ***argvPtr out Pointer to location to store a vector of strings, the additional arguments to pass to an alias. The location is in storage owned by the caller, the vector of strings is owned by the called function. .AP int *objcPtr out Pointer to location to store count of additional value arguments to be passed to the alias. The location is in storage owned by the caller. .AP Tcl_Obj ***objvPtr out Pointer to location to store a vector of Tcl_Obj structures, the additional arguments to pass to an alias command. The location is in storage owned by the caller, the vector of Tcl_Obj structures is owned by the called function. .AP "const char" *cmdName in Name of an exposed command to hide or create. .AP "const char" *hiddenCmdName in Name under which a hidden command is stored and with which it can be exposed or invoked. |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | \fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and the \fIresult\fR field in \fIaskingInterp\fR contains the error message. .PP | | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | \fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and the \fIresult\fR field in \fIaskingInterp\fR contains the error message. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if it fails; in that case, an error message is left in the value result of \fIslaveInterp\fR. Note that there are no restrictions on the ancestry relationship (as created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP \fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP \fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in which case the corresponding datum is not returned. If a result field is non\-\fBNULL\fR, the address indicated is set to the corresponding datum. For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 | it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the \fIresult\fR field in \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message in the | | | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the \fIresult\fR field in \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message in the value result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. After executing this command, attempts to use \fIcmdName\fR in a call to \fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed. .PP \fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of exposed commands to the set of hidden commands, under the name \fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the value result of \fIinterp\fR. Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and leave an error message in the value result of \fIinterp\fR. The \fICmdName\fR will be looked up in the global namespace, and not relative to the current namespace, even if the current namespace is not the global one. If a hidden command whose name is \fIhiddenCmdName\fR already exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR field in \fIinterp\fR contains an error message. If the operation succeeds, it returns \fBTCL_OK\fR. |
| ︙ | ︙ |
Changes to library/msgcat/doc/DictObj.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" 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_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" 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_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl values as dictionaries .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewDictObj\fR() .sp |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in | | | | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | \fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in If an error occurs while converting a value to be a dictionary value, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP Tcl_Obj *dictPtr in/out Points to the dictionary value to be manipulated. If \fIdictPtr\fR does not already point to a dictionary value, an attempt will be made to convert it to one. .AP Tcl_Obj *keyPtr in Points to the key for the key/value pair being manipulated within the dictionary value. .AP Tcl_Obj **keyPtrPtr out Points to a variable that will have the key from a key/value pair placed within it. May be NULL to indicate that the caller is not interested in the key. .AP Tcl_Obj *valuePtr in Points to the value for the key/value pair being manipulated within the dictionary value (or sub-value, in the case of \fBTcl_DictObjPutKeyList\fR.) .AP Tcl_Obj **valuePtrPtr out Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. .AP int *sizePtr out |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in | | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in Array of \fIkeyc\fR pointers to values that \fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will use to locate the key/value pair to manipulate within the sub-dictionaries of the main dictionary value passed to them. .BE .SH DESCRIPTION .PP Tcl dictionary values have an internal representation that supports efficient mapping from keys to values and which guarantees that the particular ordering of keys within the dictionary remains the same modulo any keys being deleted (which removes them from the order) or added (which adds them to the end of the order). If reinterpreted as a list, the values at the even-valued indices in the list will be the keys of the dictionary, and each will be followed (in the odd-valued index) by the value associated with that key. .PP The procedures described in this man page are used to create, modify, index, and iterate over dictionary values from C code. .PP \fBTcl_NewDictObj\fR creates a new, empty dictionary value. The string representation of the value will be invalid, and the reference count of the value will be zero. .PP \fBTcl_DictObjGet\fR looks up the given key within the given dictionary and writes a pointer to the value associated with that key into the variable pointed to by \fIvaluePtrPtr\fR, or a NULL if the key has no mapping within the dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be converted to a dictionary. |
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search,
&key, &value, &done) != TCL_OK) {
return TCL_ERROR;
}
for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) {
/*
* Note that strcmp() is not a good way of comparing
| | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search,
&key, &value, &done) != TCL_OK) {
return TCL_ERROR;
}
for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) {
/*
* Note that strcmp() is not a good way of comparing
* values and is just used here for demonstration
* purposes.
*/
if (!strcmp(Tcl_GetString(key), Tcl_GetString(value))) {
break;
}
}
\fBTcl_DictObjDone\fR(&search);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!done));
return TCL_OK;
.CE
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_InitObjHashTable
.SH KEYWORDS
dict, dict value, dictionary, dictionary value, hash table, iteration, value
|
Changes to library/msgcat/doc/DoubleObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl values as floating-point values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewDoubleObj\fR(\fIdoubleValue\fR) .sp \fBTcl_SetDoubleObj\fR(\fIobjPtr, doubleValue\fR) .sp int \fBTcl_GetDoubleFromObj\fR(\fIinterp, objPtr, doublePtr\fR) .SH ARGUMENTS .AS Tcl_Interp doubleValue in/out .AP double doubleValue in A double-precision floating-point value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetDoubleObj\fR, this points to the value in which to store a double value. For \fBTcl_GetDoubleFromObj\fR, this refers to the value from which to retrieve a double value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when double value retrieval fails. .AP double *doublePtr out Points to place to store the double value obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl values that hold double-precision floating-point values. .PP \fBTcl_NewDoubleObj\fR creates and returns a new Tcl value initialized to the double value \fIdoubleValue\fR. The returned Tcl value is unshared. .PP \fBTcl_SetDoubleObj\fR sets the value of an existing Tcl value pointed to by \fIobjPtr\fR to the double value \fIdoubleValue\fR. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value 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 \fBTcl_GetDoubleFromObj\fR attempts to retrieve a double value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the double value is written to the storage pointed to by \fIdoublePtr\fR. 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 \fBTcl_GetDoubleFromObj\fR more efficient. '\" TODO: add discussion of treatment of NaN value .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS double, double value, double type, internal representation, value, value type, string representation |
Changes to library/msgcat/doc/Eval.3.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. .AP int objc in The number of values in the array pointed to by \fIobjPtr\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in Points to an array of pointers to values; each value holds the value of a single word in the command to execute. .AP int numBytes in The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step can be skipped if the value is evaluated again in the future. .PP The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values | | | | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each value in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the elements of \fIobjv\fR, insuring that the values are valid until \fBTcl_EvalObjv\fR returns. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to be executed is supplied as a string instead of a value and no compilation occurs. The string should be a proper UTF-8 string as converted by \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known to possibly contain upper ASCII characters whose possible combinations might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to \fIinterp->result\fR (use is deprecated) where it can be accessed directly. This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which does not do the copy. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes additional arguments \fInumBytes\fR and \fIflags\fR. For the efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the contents of a value are going to change immediately, so the bytecodes will not be reused in a future execution. In this case, it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . If this flag is set, the script is processed at global level. This means that it is evaluated in the global namespace and its variable |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS | | | 204 205 206 207 208 209 210 211 | and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS execute, file, global, result, script, value |
Changes to library/msgcat/doc/ExprLong.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the value-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR. Those value-based procedures evaluate an expression held in a Tcl value instead of a string. The value argument can retain an internal representation that is more efficient to execute. .PP The \fIinterp\fR argument refers to an interpreter used to evaluate the expression (e.g. for variables and nested Tcl commands) and to return error information. .PP For all of these procedures the return value is a standard |
| ︙ | ︙ | |||
99 100 101 102 103 104 105 | \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS | | | 99 100 101 102 103 104 105 106 | \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS boolean, double, evaluate, expression, integer, value, string |
Changes to library/msgcat/doc/ExprLongObj.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in | | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in Pointer to a value containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the expression. .AP int *booleanPtr out Pointer to location in which to store the 0/1 boolean value of the expression. .AP Tcl_Obj **resultPtrPtr out Pointer to location in which to store a pointer to the value that is the result of the expression. .BE .SH DESCRIPTION .PP These four procedures all evaluate an expression, returning the result in one of four different forms. |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | such as .QW yes or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, | | | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | such as .QW yes or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, it stores a pointer to the Tcl value containing the expression's value at \fI*resultPtrPtr\fR. In this case, the caller is responsible for calling \fBTcl_DecrRefCount\fR to decrement the value's reference count when it is finished with the value. .SH "SEE ALSO" Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult .SH KEYWORDS boolean, double, evaluate, expression, integer, value, string |
Changes to library/msgcat/doc/FileSystem.3.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | .sp int \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | .sp int \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp const char *const * \fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR) .sp int \fBTcl_FSStat\fR(\fIpathPtr, statPtr\fR) .sp int \fBTcl_FSAccess\fR(\fIpathPtr, mode\fR) |
| ︙ | ︙ | |||
188 189 190 191 192 193 194 | .VE 8.6 .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in | | | | | | | | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | .VE 8.6 .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in The path represented by this value is used for the operation in question. If the value does not already have an internal \fBpath\fR representation, it will be converted to have one. .AP Tcl_Obj *srcPathPtr in As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. .AP Tcl_Obj *destPathPtr in As for \fIpathPtr\fR, but used for the destination filename for a copy or rename operation. .AP "const char" *encodingName in The encoding of the data stored in the file identified by \fIpathPtr\fR and to be evaluated. .AP "const char" *pattern in Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. .AP ClientData clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. .AP int elements in If non-negative, the number of elements in the \fIlistObj\fR which should be joined together. If negative, then all elements are joined. .AP Tcl_Obj **errorPtr out In the case of an error, filled with a value containing the name of the file which caused an error in the various copy/rename operations. .AP Tcl_Obj **objPtrRef out Filled with a value containing the result of the operation. .AP Tcl_Obj *resultPtr out Pre-allocated value in which to store (using \fBTcl_ListObjAppendElement\fR) the list of files or directories which are successfully matched. .AP int mode in Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK, W_OK and X_OK request checking whether the file exists and has read, write and execute permissions, respectively. F_OK just requests checking for the existence of the file. |
| ︙ | ︙ | |||
327 328 329 330 331 332 333 | listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP | | | | | | | | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP The \fBTcl_FS\fR API is \fBTcl_Obj\fR-ified and may cache internal representations and other path-related strings (e.g.\ the current working directory). One side-effect of this is that one must not pass in values with a reference count of zero to any of these functions. If such calls were handled, they might result in memory leaks (under some circumstances, the filesystem code may wish to retain a reference to the passed in value, and so one must not assume that after any of these calls return, the value still has a reference count of zero - it may have been incremented) or in a direct segmentation fault (or other memory access error) due to the value being freed part way through the complex value manipulation required to ensure that the path is fully normalized and absolute for filesystem determination. The practical lesson to learn from this is that .PP .CS Tcl_Obj *path = Tcl_NewStringObj(...); Tcl_FS\fIWhatever\fR(path); Tcl_DecrRefCount(path); .CE .PP is wrong, and may cause memory errors. The \fIpath\fR must have its reference count incremented before passing it in, or decrementing it. For this reason, values with a reference count of zero are considered not to be valid filesystem paths and calling any Tcl_FS API function with such a value will result in no action being taken. .SS "FS API FUNCTIONS" \fBTcl_FSCopyFile\fR attempts to copy the file given by \fIsrcPathPtr\fR to the path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's .QW "copy file" function is called (if it is non-NULL). |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link of one of the types passed in in the \fIlinkAction\fR flag. This flag is an ORed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. Where a choice exists (i.e.\ more than one flag is passed in), the Tcl convention is to prefer symbolic links. When a link is successfully created, the return value should be \fItoPtr\fR (which is therefore already owned by the caller). If unsuccessful, NULL is returned. |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 | .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP If the result is \fBTCL_OK\fR, then a value was placed in \fIobjPtrRef\fR, which will only be temporarily valid (unless \fBTcl_IncrRefCount\fR is called). .PP \fBTcl_FSFileAttrsSet\fR implements write access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP \fBTcl_FSFileAttrStrings\fR implements part of the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The called procedure may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it retains a reference count to the value. .PP \fBTcl_FSAccess\fR checks whether the process would be allowed to read, write or test for existence of the file (or other filesystem object) whose name is \fIpathname\fR. If \fIpathname\fR is a symbolic link on Unix, then permissions of the file referred by this symbolic link are tested. .PP |
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length 1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path | | | | | | | | | | | | | | | | | > | | | | | | | | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length 1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path value given by considering the first \fIelements\fR elements as valid path segments (each path segment may be a complete path, a partial path or just a single possible directory or file name). If any path segment is actually an absolute path, then all prior path segments are discarded. If \fIelements\fR is less than 0, we use the entire list. .PP It is possible that the returned value is actually an element of the given list, so the caller should be careful to increment the reference count of the result before freeing the list. .PP The returned value, typically with a reference count of zero (but it could be shared under some conditions), contains the joined path. The caller must add a reference count to the value before using it. In particular, the returned value could be an element of the given list, so freeing the list might free the value prematurely if no reference count has been taken. If the number of elements is zero, then the returned value will be an empty-string Tcl_Obj. .PP \fBTcl_FSSplitPath\fR takes the given Tcl_Obj, which should be a valid path, and returns a Tcl list value containing each segment of that path as an element. It returns a list value with a reference count of zero. If the passed in \fIlenPtr\fR is non-NULL, the variable it points to will be updated to contain the number of elements in the returned list. .PP \fBTcl_FSEqualPaths\fR tests whether the two paths given represent the same filesystem object. It returns 1 if the paths are equal, and 0 if they are different. If either path is NULL, 0 is always returned. .PP \fBTcl_FSGetNormalizedPath\fR this important function attempts to extract from the given Tcl_Obj a unique normalized path representation, whose string value can be used as a unique identifier for the file. .PP It returns the normalized path value, owned by Tcl, or NULL if the path was invalid or could otherwise not be successfully converted. Extraction of absolute, normalized paths is very efficient (because the filesystem operates on these representations internally), although the result when the filesystem contains numerous symbolic links may not be the most user-friendly version of a path. The return value is owned by Tcl and has a lifetime equivalent to that of the \fIpathPtr\fR passed in (unless that is a relative path, in which case the normalized path value may be freed any time the cwd changes) - the caller can of course increment the reference count if it wishes to maintain a copy for longer. .PP \fBTcl_FSJoinToPath\fR takes the given value, which should usually be a valid path or NULL, and joins onto it the array of paths segments given. .PP Returns a value, typically with reference count of zero (but it could be shared under some conditions), containing the joined path. The caller must add a reference count to the value before using it. If any of the values passed into this function (\fIpathPtr\fR or \fIpath\fR elements) have a reference count of zero, they will be freed when this function returns. .PP \fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid Tcl path type, taking account of the fact that the cwd may have changed even if this value is already supposedly of the correct type. The filename may begin with .QW ~ (to indicate current user's home directory) or .QW ~<user> (to indicate any user's home directory). .PP If the conversion succeeds (i.e.\ the value is a valid path in one of the current filesystems), then \fBTCL_OK\fR is returned. Otherwise \fBTCL_ERROR\fR is returned, and an error message may be left in the interpreter. .PP \fBTcl_FSGetInternalRep\fR extracts the internal representation of a given path value, in the given filesystem. If the path value belongs to a different filesystem, we return NULL. If the internal representation is currently NULL, we attempt to generate it, by calling the filesystem's \fBTcl_FSCreateInternalRepProc\fR. .PP Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP \fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path from the given Tcl_Obj. .PP If the translation succeeds (i.e.\ the value is a valid path), then it is returned. Otherwise NULL will be returned, and an error message may be left in the interpreter. A .QW translated path is one which contains no .QW ~ or .QW ~user sequences (these have been expanded to their current representation in the filesystem). The value returned is owned by the caller, which must store it or call \fBTcl_DecrRefCount\fR to ensure memory is freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g.\ \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an efficient way of creating the appropriate path value type. .PP The resulting value is a pure .QW path value, which will only receive a UTF-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix native filesystems, so that they can easily retrieve the native (char* or TCHAR*) representation of a path. This function is a convenience wrapper around \fBTcl_FSGetInternalRep\fR. It may be desirable in the future to have non-string-based native representations (for example, |
| ︙ | ︙ | |||
769 770 771 772 773 774 775 | or .QW prowrap , perhaps), and the second is the particular type of the given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP | | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 | or .QW prowrap , perhaps), and the second is the particular type of the given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP A valid list value is returned, unless the path value is not recognized, when NULL will be returned. .PP \fBTcl_FSGetFileSystemForPath\fR returns a pointer to the \fBTcl_Filesystem\fR which accepts this path as valid. .PP If no filesystem will accept the path, NULL is returned. .PP |
| ︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 | changes in a future Tcl release. .SS VERSION .PP The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR. .SS PATHINFILESYSTEMPROC .PP The \fIpathInFilesystemProc\fR field contains the address of a function | | | | | | | | | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
changes in a future Tcl release.
.SS VERSION
.PP
The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR.
.SS PATHINFILESYSTEMPROC
.PP
The \fIpathInFilesystemProc\fR field contains the address of a function
which is called to determine whether a given path value belongs to this
filesystem or not. Tcl will only call the rest of the filesystem
functions with a path for which this function has returned \fBTCL_OK\fR.
If the path does not belong, -1 should be returned (the behavior of Tcl
for any other return value is not defined). If \fBTCL_OK\fR is returned,
then the optional \fIclientDataPtr\fR output parameter can be used to
return an internal (filesystem specific) representation of the path,
which will be cached inside the path value, and may be retrieved
efficiently by the other filesystem functions. Tcl will simultaneously
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
ClientData *\fIclientDataPtr\fR);
.CE
.SS DUPINTERNALREPPROC
.PP
This function makes a copy of a path's internal representation, and is
called when Tcl needs to duplicate a path value. If NULL, Tcl will
simply not copy the internal representation, which may then need to be
regenerated later.
.PP
.CS
typedef ClientData \fBTcl_FSDupInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS FREEINTERNALREPPROC
Free the internal representation. This must be implemented if internal
representations need freeing (i.e.\ if some memory is allocated when an
internal representation is generated), but may otherwise be NULL.
.PP
.CS
typedef void \fBTcl_FSFreeInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS INTERNALTONORMALIZEDPROC
.PP
Function to convert internal representation to a normalized path. Only
required if the filesystem creates pure path values with no string/path
representation. The return value is a Tcl value whose string
representation is the normalized path.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR(
ClientData \fIclientData\fR);
.CE
.SS CREATEINTERNALREPPROC
.PP
Function to take a path value, and calculate an internal
representation for it, and store that native representation in the
value. May be NULL if paths have no internal representation, or if
the \fITcl_FSPathInFilesystemProc\fR for this filesystem always
immediately creates an internal representation for paths it accepts.
.PP
.CS
typedef ClientData \fBTcl_FSCreateInternalRepProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS NORMALIZEPATHPROC
.PP
Function to normalize a path. Should be implemented for all
filesystems which can have multiple string representations for the same
path value. In Tcl, every
.QW path
must have a single unique
.QW normalized
string representation. Depending on the filesystem,
there may be more than one unnormalized string representation which
refers to that path (e.g.\ a relative path, a path with different
character case if the filesystem is case insensitive, a path contain a
reference to a home directory such as
.QW ~ ,
a path containing symbolic
links, etc). If the very last component in the path is a symbolic
link, it should not be converted into the value it points to (but
its case or other aspects should be made unique). All other path
components should be converted from symbolic links. This one
exception is required to agree with Tcl's semantics with \fBfile
delete\fR, \fBfile rename\fR, \fBfile copy\fR operating on symbolic links.
This function may be called with \fInextCheckpoint\fR either
at the beginning of the path (i.e.\ zero), at the end of the path, or
at any intermediate file separator in the path. It will never
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 | and should be returned as the string representation of the Tcl_Obj which is returned. A typical return value might be .QW networked , .QW zip or .QW ftp . The Tcl_Obj result is owned by the filesystem and so Tcl will | | | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
and should be returned as the string representation of the Tcl_Obj
which is returned. A typical return value might be
.QW networked ,
.QW zip
or
.QW ftp .
The Tcl_Obj result is owned by the filesystem and so Tcl will
increment the reference count of that value if it wishes to retain a reference
to it.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSFilesystemPathTypeProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS FILESYSTEMSEPARATORPROC
.PP
Function to return the separator character(s) for this filesystem.
This need only be implemented if the filesystem wishes to use a
different separator than the standard string
.QW / .
Amongst other
uses, it is returned by the \fBfile separator\fR command. The
return value should be a value with reference count of zero.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSFilesystemSeparatorProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS STATPROC
.PP
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 | documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be | | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 | documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be added to the \fIresultPtr\fR value given (which can be assumed to be a valid unshared Tcl list). The matches added to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR (this usually means they will be absolute path specifications). Note that if no matches are found, that simply leads to an empty result; errors are only signaled for actual file or filesystem problems which may occur during the matching process. .PP |
| ︙ | ︙ | |||
1322 1323 1324 1325 1326 1327 1328 | .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller (and should therefore have its ref count incremented before being returned). Any callers | | | | | | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 | .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller (and should therefore have its ref count incremented before being returned). Any callers should call \fBTcl_DecrRefCount\fR on this result when it is no longer needed. If \fItoPtr\fR is not NULL, the function should attempt to create a link. The result in this case should be \fItoPtr\fR if the link was successful and NULL otherwise. In this case the result is not owned by the caller (i.e.\ no reference count manipulations on either end are needed). See the documentation for \fBTcl_FSLink\fR for the correct interpretation of the \fIlinkAction\fR flags. .SS LISTVOLUMESPROC .PP 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, so that they can be returned by \fBfile volumes\fR. .PP .CS typedef Tcl_Obj *\fBTcl_FSListVolumesProc\fR(void); .CE .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a .QW "master list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then they simply increment the reference count of their master list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC .PP Function to list all attribute strings which are valid for this |
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it returns a value with a reference count of at least one. .SS FILEATTRSGETPROC .PP Function to process a \fBTcl_FSFileAttrsGet\fR call, used by \fBfile attributes\fR. .PP .CS |
| ︙ | ︙ |
Changes to library/msgcat/doc/GetIndex.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
msg, flags, indexPtr\fR)
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
| | > > > > > > | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
msg, flags, indexPtr\fR)
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this value is used to search through \fItablePtr\fR.
The internal representation is modified to hold the index of the matching
table entry.
.AP "const char *const" *tablePtr in
An array of null-terminated strings. The end of the array is marked
by a NULL string pointer.
Note that references to the \fItablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array.
.AP "const void" *structTablePtr in
An array of arbitrary type, typically some \fBstruct\fR type.
The first member of the structure must be a null-terminated string.
The size of the structure is given by \fIoffset\fR.
Note that references to the \fIstructTablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array of structures.
.AP int offset in
The offset to add to structTablePtr to get to the next entry.
The end of the array is marked by a NULL string pointer.
.AP "const char" *msg in
Null-terminated string describing what is being looked up, such as
\fBoption\fR. This string is included in error messages.
.AP int flags in
OR-ed combination of bits providing additional information for
operation. The only bit that is currently defined is \fBTCL_EXACT\fR.
.AP int *indexPtr out
The index of the string in \fItablePtr\fR that matches the value of
\fIobjPtr\fR is returned here.
.BE
.SH DESCRIPTION
.PP
These procedures provide an efficient way for looking up keywords,
switch names, option names, and similar things where the literal value of
a Tcl value must be chosen from a predefined set.
\fBTcl_GetIndexFromObj\fR compares \fIobjPtr\fR against each of
the strings in \fItablePtr\fR to find a match. A match occurs if
\fIobjPtr\fR's string value is identical to one of the strings in
\fItablePtr\fR, or if it is a non-empty unique abbreviation
for exactly one of the strings in \fItablePtr\fR and the
\fBTCL_EXACT\fR flag was not specified; in either case
the index of the matching entry is stored at \fI*indexPtr\fR
and \fBTCL_OK\fR is returned.
|
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS | | | 97 98 99 100 101 102 103 104 | array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS index, option, value, table lookup |
Changes to library/msgcat/doc/Hash.3.
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
.PP
.CS
typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
.PP
| | | | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
.PP
.CS
typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
.PP
If this is NULL then \fBTcl_Alloc\fR is used to allocate enough space for a
Tcl_HashEntry, the key pointer is assigned to key.oneWordValue and the
clientData is set to NULL. String keys and array keys use this function to
allocate enough space for the entry and the key in one block, rather than
doing it in two blocks. This saves space for a pointer to the key from the
entry and another memory allocation. Tcl_Obj* keys use this function to
allocate enough space for an entry and increment the reference count on the
value.
.PP
The \fIfreeEntryProc\fR member contains the address of a function called to
free space for an entry.
.PP
.CS
typedef void \fBTcl_FreeHashEntryProc\fR(
Tcl_HashEntry *\fIhPtr\fR);
.CE
.PP
If this is NULL then \fBTcl_Free\fR is used to free the space for the entry.
Tcl_Obj* keys use this function to decrement the reference count on the
value.
.SH KEYWORDS
hash table, key, lookup, search, value
|
Changes to library/msgcat/doc/InitStubs.3.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard | | | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the library name is \fItclstub86.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for more information. .SH DESCRIPTION \fBTcl_InitStubs\fR attempts to initialize the stub table pointers |
| ︙ | ︙ |
Changes to library/msgcat/doc/IntObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .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 .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in | | | | | | | | | | | | | | > | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR, this points to the value in which to store an integral value. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR, this refers to the value from which to retrieve an integral value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when integral value retrieval fails. .AP int *intPtr out Points to place to store the integer value retrieved from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out Points to a multi-precision integer structure declared by the LibTomMath library. .AP double doubleValue in Double value from which the integer part is determined and used to initialize a multi-precision integer value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl values that hold integral values. .PP The different routines exist to accommodate different integral types in C with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types 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, \fBint64\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new Tcl value initialized to the integral value of the argument. The returned Tcl value is unshared. .PP The \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR routines each set the value of an existing Tcl value pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value 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_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral value of the appropriate type 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 integral value, or if the value exceeds the range of the target type. 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. Unlike the other functions, \fBTcl_TakeBignumFromObj\fR may set the content of the Tcl value \fIobjPtr\fR to an empty string in the process of retrieving the multiple-precision integer value. .PP The choice between \fBTcl_GetBignumFromObj\fR and \fBTcl_TakeBignumFromObj\fR is governed by how the caller will continue to use \fIobjPtr\fR. If after the \fBmp_int\fR value is retrieved from \fIobjPtr\fR, the caller will make no more use of \fIobjPtr\fR, then using \fBTcl_TakeBignumFromObj\fR permits Tcl to detect when an unshared \fIobjPtr\fR permits the value to be moved instead of copied, which should be more efficient. If anything later in the caller requires \fIobjPtr\fR to continue to hold the same value, then \fBTcl_GetBignumFromObj\fR must be chosen. .PP The \fBTcl_InitBignumFromDouble\fR routine is a utility procedure that extracts the integer part of \fIdoubleValue\fR and stores that integer value in the \fBmp_int\fR value \fIbigValue\fR. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS integer, integer value, integer type, internal representation, value, value type, string representation |
Changes to library/msgcat/doc/ListObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl values as lists .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_ListObjAppendList\fR(\fIinterp, listPtr, elemListPtr\fR) .sp |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | \fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR) .sp int \fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *elemListPtr in/out .AP Tcl_Interp *interp in | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
\fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR)
.sp
int
\fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR)
.SH ARGUMENTS
.AS "Tcl_Obj *const" *elemListPtr in/out
.AP Tcl_Interp *interp in
If an error occurs while converting a value to be a list value,
an error message is left in the interpreter's result value
unless \fIinterp\fR is NULL.
.AP Tcl_Obj *listPtr in/out
Points to the list value to be manipulated.
If \fIlistPtr\fR does not already point to a list value,
an attempt will be made to convert it to one.
.AP Tcl_Obj *elemListPtr in/out
For \fBTcl_ListObjAppendList\fR, this points to a list value
containing elements to be appended onto \fIlistPtr\fR.
Each element of *\fIelemListPtr\fR will
become a new element of \fIlistPtr\fR.
If *\fIelemListPtr\fR is not NULL and
does not already point to a list value,
an attempt will be made to convert it to one.
.AP Tcl_Obj *objPtr in
For \fBTcl_ListObjAppendElement\fR,
points to the Tcl value that will be appended to \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
this points to the Tcl value that will be converted to a list value
containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR.
.AP int *objcPtr in
Points to location where \fBTcl_ListObjGetElements\fR
stores the number of element values in \fIlistPtr\fR.
.AP Tcl_Obj ***objvPtr out
A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array
of pointers to the element values of \fIlistPtr\fR.
.AP int objc in
The number of Tcl values that \fBTcl_NewListObj\fR
will insert into a new list value,
and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
the number of Tcl values to insert into \fIobjPtr\fR.
.AP "Tcl_Obj *const" objv[] in
An array of pointers to values.
\fBTcl_NewListObj\fR will insert these values into a new list value
and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR.
Each value will become a separate list element.
.AP int *intPtr out
Points to location where \fBTcl_ListObjLength\fR
stores the length of the list.
.AP int index in
Index of the list element that \fBTcl_ListObjIndex\fR
is to return.
The first element has index 0.
.AP Tcl_Obj **objPtrPtr out
Points to place where \fBTcl_ListObjIndex\fR is to store
a pointer to the resulting list element value.
.AP int first in
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
.AP int count in
The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE
.SH DESCRIPTION
.PP
Tcl list values have an internal representation that supports
the efficient indexing and appending.
The procedures described in this man page are used to
create, modify, index, and append to Tcl list values from C code.
.PP
\fBTcl_ListObjAppendList\fR and \fBTcl_ListObjAppendElement\fR
both add one or more values
to the end of the list value referenced by \fIlistPtr\fR.
\fBTcl_ListObjAppendList\fR appends each element of the list value
referenced by \fIelemListPtr\fR while
\fBTcl_ListObjAppendElement\fR appends the single value
referenced by \fIobjPtr\fR.
Both procedures will convert the value referenced by \fIlistPtr\fR
to a list value if necessary.
If an error occurs during conversion,
both procedures return \fBTCL_ERROR\fR and leave an error message
in the interpreter's result value if \fIinterp\fR is not NULL.
Similarly, if \fIelemListPtr\fR does not already refer to a list value,
\fBTcl_ListObjAppendList\fR will attempt to convert it to one
and if an error occurs during conversion,
will return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result value
if interp is not NULL.
Both procedures invalidate any old string representation of \fIlistPtr\fR
and, if it was converted to a list value,
free any old internal representation.
Similarly, \fBTcl_ListObjAppendList\fR frees any old internal representation
of \fIelemListPtr\fR if it converts it to a list value.
After appending each element in \fIelemListPtr\fR,
\fBTcl_ListObjAppendList\fR increments the element's reference count
since \fIlistPtr\fR now also refers to it.
For the same reason, \fBTcl_ListObjAppendElement\fR
increments \fIobjPtr\fR's reference count.
If no error occurs,
the two procedures return \fBTCL_OK\fR after appending the values.
.PP
\fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR
create a new value or modify an existing value to hold
the \fIobjc\fR elements of the array referenced by \fIobjv\fR
where each element is a pointer to a Tcl value.
If \fIobjc\fR is less than or equal to zero,
they return an empty value.
The new value's string representation is left invalid.
The two procedures increment the reference counts
of the elements in \fIobjc\fR since the list value now refers to them.
The new list value returned by \fBTcl_NewListObj\fR
has reference count zero.
.PP
\fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of
the elements in a list value. It returns the count by storing it in the
address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing
it in the address \fIobjvPtr\fR.
The memory pointed to is managed by Tcl and should not be freed or written
to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR
and NULL at \fIobjvPtr\fR.
If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR
will attempt to convert it to one; if the conversion fails, it returns
\fBTCL_ERROR\fR and leaves an error message in the interpreter's result
value if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer.
.PP
\fBTcl_ListObjLength\fR returns the number of elements in the list value
referenced by \fIlistPtr\fR.
It returns this count by storing an integer in the address \fIintPtr\fR.
If the value is not already a list value,
\fBTcl_ListObjLength\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the list's length.
.PP
The procedure \fBTcl_ListObjIndex\fR returns a pointer to the value
at element \fIindex\fR in the list referenced by \fIlistPtr\fR.
It returns this value by storing a pointer to it
in the address \fIobjPtrPtr\fR.
If \fIlistPtr\fR does not already refer to a list value,
\fBTcl_ListObjIndex\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
If the index is out of range,
that is, \fIindex\fR is negative or
greater than or equal to the number of elements in the list,
\fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR
and returns \fBTCL_OK\fR.
Otherwise it returns \fBTCL_OK\fR after storing the element's
value pointer.
The reference count for the list element is not incremented;
the caller must do that if it needs to retain a pointer to the element.
.PP
\fBTcl_ListObjReplace\fR replaces zero or more elements
of the list referenced by \fIlistPtr\fR
with the \fIobjc\fR values in the array referenced by \fIobjv\fR.
If \fIlistPtr\fR does not point to a list value,
\fBTcl_ListObjReplace\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise, it returns \fBTCL_OK\fR after replacing the values.
If \fIobjv\fR is NULL, no new elements are added.
If the argument \fIfirst\fR is zero or negative,
it refers to the first element.
If \fIfirst\fR is greater than or equal to the
number of elements in the list, then no elements are deleted;
the new elements are appended to the list.
\fIcount\fR gives the number of elements to replace.
If \fIcount\fR is zero or negative then no elements are deleted;
the new elements are simply inserted before the one
designated by \fIfirst\fR.
\fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's
old string representation.
The reference counts of any elements inserted from \fIobjv\fR
are incremented since the resulting list now refers to them.
Similarly, the reference counts for any replaced values are decremented.
.PP
Because \fBTcl_ListObjReplace\fR combines
both element insertion and deletion,
it can be used to implement a number of list operations.
For example, the following code inserts the \fIobjc\fR values
referenced by the array of value pointers \fIobjv\fR
just before the element \fIindex\fR of the list referenced by \fIlistPtr\fR:
.PP
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, index, 0,
objc, objv);
.CE
.PP
Similarly, the following code appends the \fIobjc\fR values
referenced by the array \fIobjv\fR
to the end of the list \fIlistPtr\fR:
.PP
.CS
result = \fBTcl_ListObjLength\fR(interp, listPtr, &length);
if (result == TCL_OK) {
result = \fBTcl_ListObjReplace\fR(interp, listPtr, length, 0,
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
| | > | 243 244 245 246 247 248 249 250 251 |
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
append, index, insert, internal representation, length, list, list value,
list type, value, value type, replace, string representation
|
Changes to library/msgcat/doc/Load.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | The name of the file to load. If it is a single name, the library search path of the current environment will be used to resolve it. .AP "const char *const" symbols[] in Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in | | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | The name of the file to load. If it is a single name, the library search path of the current environment will be used to resolve it. .AP "const char *const" symbols[] in Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in The value should normally be 0, but \fITCL_LOAD_GLOBAL\fR or \fITCL_LOAD_LAZY\fR or a combination of those two is allowed as well. .AP void *procPtrs out Points to an array that will hold the addresses of the functions described in the \fIsymbols\fR argument. Should be NULL if no symbols are to be resolved. .AP Tcl_LoadHandle *loadHandlePtr out Points to a variable that will hold the handle to the abstract token describing the library that has been loaded. .AP Tcl_LoadHandle loadHandle in |
| ︙ | ︙ |
Changes to library/msgcat/doc/NRE.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | .AP Tcl_CmdDeleteProc *deleteProc in/out Procedure to call before \fIcmdName\fR is deleted from the interpreter. This procedure allows for command-specific cleanup. If \fIdeleteProc\fR is \fBNULL\fR, then no procedure is called before the command is deleted. .AP int objc in Count of parameters provided to the implementation of a command. .AP Tcl_Obj **objv in | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .AP Tcl_CmdDeleteProc *deleteProc in/out Procedure to call before \fIcmdName\fR is deleted from the interpreter. This procedure allows for command-specific cleanup. If \fIdeleteProc\fR is \fBNULL\fR, then no procedure is called before the command is deleted. .AP int objc in Count of parameters provided to the implementation of a command. .AP Tcl_Obj **objv in Pointer to an array of Tcl values. Each value holds the value of a single word in the command to execute. .AP Tcl_Obj *objPtr in Pointer to a Tcl_Obj whose value is a script or expression to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported. .\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and |
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | invoke a single Tcl command whose words have already been separated and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the words of the command to be evaluated when execution reaches the trampoline. .PP \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose resolution is already known. The \fIcmd\fR parameter gives a | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | invoke a single Tcl command whose words have already been separated and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the words of the command to be evaluated when execution reaches the trampoline. .PP \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose resolution is already known. The \fIcmd\fR parameter gives a \fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or \fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in the trampoline; this command must match the word in \fIobjv[0]\fR. The remaining arguments are as for \fBTcl_NREvalObj\fR. .PP \fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR all accept a \fIflags\fR parameter, which is an OR-ed-together set of bits to control evaluation. At the present time, the only supported flag |
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
| | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
* passed to \fBTcl_NRAddCallback\fR */
\fI... postprocessing ...\fR
return result;
}
.CE
.PP
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
| | | 319 320 321 322 323 324 325 326 327 328 |
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
stackless, nonrecursive, execute, command, global, value, result, script
.SH COPYRIGHT
Copyright (c) 2008 by Kevin B. Kenny
|
Changes to library/msgcat/doc/Namespace.3.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out A reference to an unshared value to which the function output will be written. .AP "const char" *pattern in The glob-style pattern (see \fBTcl_StringMatch\fR) that describes the commands to be imported or exported. .AP int resetListFirst in Whether the list of export patterns should be reset before adding the current pattern to it. |
| ︙ | ︙ |
Changes to library/msgcat/doc/Object.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewObj\fR() .sp |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp \fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in | | | > | | | | | | | | | | | | | | | | | | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
int
\fBTcl_IsShared\fR(\fIobjPtr\fR)
.sp
\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)
.SH ARGUMENTS
.AS Tcl_Obj *objPtr
.AP Tcl_Obj *objPtr in
Points to a value;
must have been the result of a previous call to \fBTcl_NewObj\fR.
.BE
.SH INTRODUCTION
.PP
This man page presents an overview of Tcl values (called \fBTcl_Obj\fRs for
historical reasons) and how they are used.
It also describes generic procedures for managing Tcl values.
These procedures are used to create and copy values,
and increment and decrement the count of references (pointers) to values.
The procedures are used in conjunction with ones
that operate on specific types of values such as
\fBTcl_GetIntFromObj\fR and \fBTcl_ListObjAppendElement\fR.
The individual procedures are described along with the data structures
they manipulate.
.PP
Tcl's \fIdual-ported\fR values provide a general-purpose mechanism
for storing and exchanging Tcl values.
They largely replace the use of strings in Tcl.
For example, they are used to store variable values,
command arguments, command results, and scripts.
Tcl values behave like strings but also hold an internal representation
that can be manipulated more efficiently.
For example, a Tcl list is now represented as a value
that holds the list's string representation
as well as an array of pointers to the values for each list element.
Dual-ported values avoid most runtime type conversions.
They also improve the speed of many operations
since an appropriate representation is immediately available.
The compiler itself uses Tcl values to
cache the instruction bytecodes resulting from compiling scripts.
.PP
The two representations are a cache of each other and are computed lazily.
That is, each representation is only computed when necessary,
it is computed from the other representation,
and, once computed, it is saved.
In addition, a change in one representation invalidates the other one.
As an example, a Tcl program doing integer calculations can
operate directly on a variable's internal machine integer
representation without having to constantly convert
between integers and strings.
Only when it needs a string representing the variable's value,
say to print it,
will the program regenerate the string representation from the integer.
Although values contain an internal representation,
their semantics are defined in terms of strings:
an up-to-date string can always be obtained,
and any change to the value will be reflected in that string
when the value's string representation is fetched.
Because of this representation invalidation and regeneration,
it is dangerous for extension writers to access
\fBTcl_Obj\fR fields directly.
It is better to access Tcl_Obj information using
procedures like \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR.
.PP
Values are allocated on the heap
and are referenced using a pointer to their \fBTcl_Obj\fR structure.
Values are shared as much as possible.
This significantly reduces storage requirements
because some values such as long lists are very large.
Also, most Tcl values are only read and never modified.
This is especially true for procedure arguments,
which can be shared between the caller and the called procedure.
Assignment and argument binding is done by
simply assigning a pointer to the value.
Reference counting is used to determine when it is safe to
reclaim a value's storage.
.PP
Tcl values are typed.
A value's internal representation is controlled by its type.
Several types are predefined in the Tcl core
including integer, double, list, and bytecode.
Extension writers can extend the set of types
by defining their own \fBTcl_ObjType\fR structs.
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
int \fIrefCount\fR;
char *\fIbytes\fR;
int \fIlength\fR;
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
a value's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
this allows string representations
to be treated as conventional null-terminated C strings.
C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
a value's string representation.
If \fIbytes\fR is NULL,
the string representation is invalid.
.PP
A value's type manages its internal representation.
The member \fItypePtr\fR points to the Tcl_ObjType structure
that describes the type.
If \fItypePtr\fR is NULL,
the internal representation is invalid.
.PP
The \fIinternalRep\fR union member holds
a value's internal representation.
This is either a (long) integer, a double-precision floating-point number,
a pointer to a value containing additional information
needed by the value's type to represent the value, a Tcl_WideInt
integer, two arbitrary pointers, or a pair made up of an unsigned long
integer and a pointer.
.PP
The \fIrefCount\fR member is used to tell when it is safe to free
a value's storage.
It holds the count of active references to the value.
Maintaining the correct reference count is a key responsibility
of extension writers.
Reference counting is discussed below
in the section \fBSTORAGE MANAGEMENT OF VALUES\fR.
.PP
Although extension writers can directly access
the members of a Tcl_Obj structure,
it is much better to use the appropriate procedures and macros.
For example, extension writers should never
read or update \fIrefCount\fR directly;
they should use macros such as
\fBTcl_IncrRefCount\fR and \fBTcl_IsShared\fR instead.
.PP
A key property of Tcl values is that they hold two representations.
A value typically starts out containing only a string representation:
it is untyped and has a NULL \fItypePtr\fR.
A value containing an empty string or a copy of a specified string
is created using \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR respectively.
A value's string value is gotten with
\fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR
and changed with \fBTcl_SetStringObj\fR.
If the value is later passed to a procedure like \fBTcl_GetIntFromObj\fR
that requires a specific internal representation,
the procedure will create one and set the value's \fItypePtr\fR.
The internal representation is computed from the string representation.
A value's two representations are duals of each other:
changes made to one are reflected in the other.
For example, \fBTcl_ListObjReplace\fR will modify a value's
internal representation and the next call to \fBTcl_GetStringFromObj\fR
or \fBTcl_GetString\fR will reflect that change.
.PP
Representations are recomputed lazily for efficiency.
A change to one representation made by a procedure
such as \fBTcl_ListObjReplace\fR is not reflected immediately
in the other representation.
Instead, the other representation is marked invalid
so that it is only regenerated if it is needed later.
Most C programmers never have to be concerned with how this is done
and simply use procedures such as \fBTcl_GetBooleanFromObj\fR or
\fBTcl_ListObjIndex\fR.
Programmers that implement their own value types
must check for invalid representations
and mark representations invalid when necessary.
The procedure \fBTcl_InvalidateStringRep\fR is used
to mark a value's string representation invalid and to
free any storage associated with the old string representation.
.PP
Values usually remain one type over their life,
but occasionally a value must be converted from one type to another.
For example, a C program might build up a string in a value
with repeated calls to \fBTcl_AppendToObj\fR,
and then call \fBTcl_ListObjIndex\fR to extract a list element from
the value.
The same value holding the same string value
can have several different internal representations
at different times.
Extension writers can also force a value to be converted from one type
to another using the \fBTcl_ConvertToType\fR procedure.
Only programmers that create new value types need to be concerned
about how this is done.
A procedure defined as part of the value type's implementation
creates a new internal representation for a value
and changes its \fItypePtr\fR.
See the man page for \fBTcl_RegisterObjType\fR
to see how to create a new value type.
.SH "EXAMPLE OF THE LIFETIME OF A VALUE"
.PP
As an example of the lifetime of a value,
consider the following sequence of commands:
.PP
.CS
\fBset x 123\fR
.CE
.PP
This assigns to \fIx\fR an untyped value whose
\fIbytes\fR member points to \fB123\fR and \fIlength\fR member contains 3.
The value's \fItypePtr\fR member is NULL.
.PP
.CS
\fBputs "x is $x"\fR
.CE
.PP
\fIx\fR's string representation is valid (since \fIbytes\fR is non-NULL)
and is fetched for the command.
.PP
.CS
\fBincr x\fR
.CE
.PP
The \fBincr\fR command first gets an integer from \fIx\fR's value
by calling \fBTcl_GetIntFromObj\fR.
This procedure checks whether the value is already an integer value.
Since it is not, it converts the value
by setting the value's \fIinternalRep.longValue\fR member
to the integer \fB123\fR
and setting the value's \fItypePtr\fR
to point to the integer Tcl_ObjType structure.
Both representations are now valid.
\fBincr\fR increments the value's integer internal representation
then invalidates its string representation
(by calling \fBTcl_InvalidateStringRep\fR)
since the string representation
no longer corresponds to the internal representation.
.PP
.CS
\fBputs "x is now $x"\fR
.CE
.PP
The string representation of \fIx\fR's value is needed
and is recomputed.
The string representation is now \fB124\fR
and both representations are again valid.
.SH "STORAGE MANAGEMENT OF VALUES"
.PP
Tcl values are allocated on the heap and are shared as much as possible
to reduce storage requirements.
Reference counting is used to determine when a value is
no longer needed and can safely be freed.
A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR
has \fIrefCount\fR 0.
The macro \fBTcl_IncrRefCount\fR increments the reference count
when a new reference to the value is created.
The macro \fBTcl_DecrRefCount\fR decrements the count
when a reference is no longer needed and,
if the value's reference count drops to zero, frees its storage.
A value shared by different code or data structures has
\fIrefCount\fR greater than 1.
Incrementing a value's reference count ensures that
it will not be freed too early or have its value change accidentally.
.PP
As an example, the bytecode interpreter shares argument values
between calling and called Tcl procedures to avoid having to copy values.
It assigns the call's argument values to the procedure's
formal parameter variables.
In doing so, it calls \fBTcl_IncrRefCount\fR to increment
the reference count of each argument since there is now a new
reference to it from the formal parameter.
When the called procedure returns,
the interpreter calls \fBTcl_DecrRefCount\fR to decrement
each argument's reference count.
When a value's reference count drops less than or equal to zero,
\fBTcl_DecrRefCount\fR reclaims its storage.
Most command procedures do not have to be concerned about
reference counting since they use a value's value immediately
and do not retain a pointer to the value after they return.
However, if they do retain a pointer to a value in a data structure,
they must be careful to increment its reference count
since the retained pointer is a new reference.
.PP
Command procedures that directly modify values
such as those for \fBlappend\fR and \fBlinsert\fR must be careful to
copy a shared value before changing it.
They must first check whether the value is shared
by calling \fBTcl_IsShared\fR.
If the value is shared they must copy the value
by using \fBTcl_DuplicateObj\fR;
this returns a new duplicate of the original value
that has \fIrefCount\fR 0.
If the value is not shared,
the command procedure
.QW "owns"
the value and can safely modify it directly.
For example, the following code appears in the command procedure
that implements \fBlinsert\fR.
This procedure modifies the list value passed to it in \fIobjv[1]\fR
by inserting \fIobjc-3\fR new elements before \fIindex\fR.
.PP
.CS
listPtr = objv[1];
if (\fBTcl_IsShared\fR(listPtr)) {
listPtr = \fBTcl_DuplicateObj\fR(listPtr);
}
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]));
.CE
.PP
As another example, \fBincr\fR's command procedure
must check whether the variable's value is shared before
incrementing the integer in its internal representation.
If it is shared, it needs to duplicate the value
in order to avoid accidentally changing values in other data structures.
.SH "SEE ALSO"
Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3)
.SH KEYWORDS
internal representation, value, value creation, value type,
reference counting, string representation, type conversion
|
Changes to library/msgcat/doc/ObjectType.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | > | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl value types .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_RegisterObjType\fR(\fItypePtr\fR) .sp const Tcl_ObjType * \fBTcl_GetObjType\fR(\fItypeName\fR) .sp int \fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR) .SH ARGUMENTS .AS "const char" *typeName .AP "const Tcl_ObjType" *typePtr in Points to the structure containing information about the Tcl value type. This storage must live forever, typically by being statically allocated. .AP "const char" *typeName in The name of a Tcl value type that \fBTcl_GetObjType\fR should look up. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP Tcl_Obj *objPtr in For \fBTcl_AppendAllObjTypes\fR, this points to the value onto which it appends the name of each value type as a list element. For \fBTcl_ConvertToType\fR, this points to a value that must have been the result of a previous call to \fBTcl_NewObj\fR. .BE .SH DESCRIPTION .PP The procedures in this man page manage Tcl value types (sometimes referred to as object types or \fBTcl_ObjType\fRs for historical reasons). They are used to register new value types, look up types, and force conversions from one type to another. .PP \fBTcl_RegisterObjType\fR registers a new Tcl value type in the table of all value types that \fBTcl_GetObjType\fR can look up by name. There are other value types supported by Tcl as well, which Tcl chooses not to register. Extensions can likewise choose to register the value types they create or not. The argument \fItypePtr\fR points to a Tcl_ObjType structure that describes the new type by giving its name and by supplying pointers to four procedures that implement the type. If the type table already contains a type with the same name as in \fItypePtr\fR, it is replaced with the new type. The Tcl_ObjType structure is described in the section \fBTHE TCL_OBJTYPE STRUCTURE\fR below. .PP \fBTcl_GetObjType\fR returns a pointer to the registered Tcl_ObjType with name \fItypeName\fR. It returns NULL if no type with that name is registered. .PP \fBTcl_AppendAllObjTypes\fR appends the name of each registered value type as a list element onto the Tcl value referenced by \fIobjPtr\fR. The return value is \fBTCL_OK\fR unless there was an error converting \fIobjPtr\fR to a list value; in that case \fBTCL_ERROR\fR is returned. .PP \fBTcl_ConvertToType\fR converts a value from one type to another if possible. It creates a new internal representation for \fIobjPtr\fR appropriate for the target type \fItypePtr\fR and sets its \fItypePtr\fR member as determined by calling the \fItypePtr->setFromAnyProc\fR routine. Any internal representation for \fIobjPtr\fR's old type is freed. If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the result value for \fIinterp\fR unless \fIinterp\fR is NULL. Otherwise, it returns \fBTCL_OK\fR. Passing a NULL \fIinterp\fR allows this procedure to be used as a test whether the conversion can be done (and in fact was done). .VS 8.5 .PP In many cases, the \fItypePtr->setFromAnyProc\fR routine will set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR, but that is no longer guaranteed. The \fIsetFromAnyProc\fR is free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. .VE 8.5 .SH "THE TCL_OBJTYPE STRUCTURE" .PP Extension writers can define new value types by defining four procedures and initializing a Tcl_ObjType structure to describe the type. Extension writers may also pass a pointer to their Tcl_ObjType structure to \fBTcl_RegisterObjType\fR if they wish to permit other extensions to look up their Tcl_ObjType by name with the \fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is defined as follows: |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | .SS "THE NAME FIELD" .PP The \fIname\fR member describes the name of the type, e.g. \fBint\fR. When a type is registered, this is the name used by callers of \fBTcl_GetObjType\fR to lookup the type. For unregistered types, the \fIname\fR field is primarily of value for debugging. The remaining four members are pointers to procedures | | | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
.SS "THE NAME FIELD"
.PP
The \fIname\fR member describes the name of the type, e.g. \fBint\fR.
When a type is registered, this is the name used by callers
of \fBTcl_GetObjType\fR to lookup the type. For unregistered
types, the \fIname\fR field is primarily of value for debugging.
The remaining four members are pointers to procedures
called by the generic Tcl value code:
.SS "THE SETFROMANYPROC FIELD"
.PP
The \fIsetFromAnyProc\fR member contains the address of a function
called to create a valid internal representation
from a value's string representation.
.PP
.CS
typedef int \fBTcl_SetFromAnyProc\fR(
Tcl_Interp *\fIinterp\fR,
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
If an internal representation cannot be created from the string,
it returns \fBTCL_ERROR\fR and puts a message
describing the error in the result value for \fIinterp\fR
unless \fIinterp\fR is NULL.
If \fIsetFromAnyProc\fR is successful,
it stores the new internal representation,
sets \fIobjPtr\fR's \fItypePtr\fR member to point to
the \fBTcl_ObjType\fR struct corresponding to the new
internal representation, and returns \fBTCL_OK\fR.
Before setting the new internal representation,
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will lead to a panic, so to avoid this possibility, the type should \fInot\fR be registered. .SS "THE UPDATESTRINGPROC FIELD" .PP The \fIupdateStringProc\fR member contains the address of a function called to create a valid string representation | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will
lead to a panic, so to avoid this possibility, the type
should \fInot\fR be registered.
.SS "THE UPDATESTRINGPROC FIELD"
.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
from a value's internal representation.
.PP
.CS
typedef void \fBTcl_UpdateStringProc\fR(
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
\fIobjPtr\fR's \fIbytes\fR member is always NULL when it is called.
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | making use of the internal representation are written so that the string representation is never invalidated. Failure to meet this obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR or other similar routines ask for the string representation. .SS "THE DUPINTREPPROC FIELD" .PP The \fIdupIntRepProc\fR member contains the address of a function | | | | | | | | | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
making use of the internal representation are written so that the
string representation is never invalidated. Failure to meet this
obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR
or other similar routines ask for the string representation.
.SS "THE DUPINTREPPROC FIELD"
.PP
The \fIdupIntRepProc\fR member contains the address of a function
called to copy an internal representation from one value to another.
.PP
.CS
typedef void \fBTcl_DupInternalRepProc\fR(
Tcl_Obj *\fIsrcPtr\fR,
Tcl_Obj *\fIdupPtr\fR);
.CE
.PP
\fIdupPtr\fR's internal representation is made a copy of \fIsrcPtr\fR's
internal representation.
Before the call,
\fIsrcPtr\fR's internal representation is valid and \fIdupPtr\fR's is not.
\fIsrcPtr\fR's value type determines what
copying its internal representation means.
.PP
For example, the \fIdupIntRepProc\fR for the Tcl integer type
simply copies an integer.
The built-in list type's \fIdupIntRepProc\fR uses a far more
sophisticated scheme to continue sharing storage as much as it
reasonably can.
.SS "THE FREEINTREPPROC FIELD"
.PP
The \fIfreeIntRepProc\fR member contains the address of a function
that is called when a value is freed.
.PP
.CS
typedef void \fBTcl_FreeInternalRepProc\fR(
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
The \fIfreeIntRepProc\fR function can deallocate the storage
for the value's internal representation
and do other type-specific processing necessary when a value is freed.
.PP
For example, the list type's \fIfreeIntRepProc\fR respects
the storage sharing scheme established by the \fIdupIntRepProc\fR
so that it only frees storage when the last value sharing it
is being freed.
.PP
The \fIfreeIntRepProc\fR member can be set to NULL
to indicate that the internal representation does not require freeing.
The \fIfreeIntRepProc\fR implementation must not access the
\fIbytes\fR member of the value, since Tcl makes its own internal
uses of that field during value deletion. The defined tasks for
the \fIfreeIntRepProc\fR have no need to consult the \fIbytes\fR
member.
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3)
.SH KEYWORDS
internal representation, value, value type, string representation, type conversion
|
Changes to library/msgcat/doc/OpenFileChnl.3.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out | | | | | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. .AP int charsToRead in The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. .AP int bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl value in which to store the line read from the channel. The line read will be appended to the current value of the value. .AP Tcl_DString *lineRead in/out A pointer to a Tcl dynamic string in which to store the line read from the channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. .AP int inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or beginning of the channel buffer. .AP Tcl_Obj *writeObjPtr in A pointer to a Tcl value whose contents will be output to the channel. .AP "const char" *charBuf in A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. .AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. |
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. As of Tcl 8.4, the value-based API \fBTcl_FSOpenFileChannel\fR should be used in preference to \fBTcl_OpenFileChannel\fR wherever possible. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. 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. |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a list value. \fBTcl_GetChannelNamesEx\fR will filter these names according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it will not do any filtering. The return value is \fBTCL_OK\fR if no errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR, and the error message is left in the interpreter's result. .SH TCL_REGISTERCHANNEL .PP \fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible |
| ︙ | ︙ | |||
431 432 433 434 435 436 437 | end-of-line recognition mode. End-of-line recognition and the various platform-specific modes are described in the manual entry for the Tcl \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a | | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 | end-of-line recognition mode. End-of-line recognition and the various platform-specific modes are described in the manual entry for the Tcl \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a byte-array value. The string representation of this value will only be constructed if it is needed (e.g., because of a call to \fBTcl_GetStringFromObj\fR). In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it does not do |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | no data was available or the data that was available did not contain an end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | no data was available or the data that was available did not contain an end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by \fIlineRead\fR rather than a Tcl value. .SH "TCL_UNGETS" .PP \fBTcl_Ungets\fR is used to add data to the input queue of a channel, at either the head or tail of the queue. The pointer \fIinput\fR points to the data that is to be added. The length of the input to add is given by \fIinputLen\fR. A non-zero value of \fIaddAtEnd\fR indicates that the data is to be added at the end of queue; otherwise it will be added at the |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it accepts a Tcl value whose contents will be output to the channel. The UTF-8 characters in \fIwriteObjPtr\fR's string representation are converted to the channel's encoding and queued for output to \fIchannel\fR. As a performance optimization, when writing to a channel with the encoding \fBbinary\fR, UTF-8 characters are not converted as they are written. Instead, the bytes in \fIwriteObjPtr\fR's internal representation as a byte-array value are written to the channel. The byte-array representation of the value will be constructed if it is needed. In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it does not do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized |
| ︙ | ︙ |
Changes to library/msgcat/doc/ParseArgs.3.
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
| | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
\fIobjPtr\fR is the value that represents the following argument or NULL if
there are no following arguments at all, and the \fIdstPtr\fR argument to the
\fBTcl_ArgvFuncProc\fR is the location to write the parsed value to.
.RE
.TP
\fBTCL_ARGV_GENFUNC\fR
.
This argument takes zero or more following arguments; the handler callback
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. .TP \fBTCL_ARGV_STRING\fR . This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. .TP \fBTCL_ARGV_STRING\fR . This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked to the lifetime of the string representation of the argument value that it came from, and so should be copied if it needs to be retained. The \fIsrcPtr\fR and \fIclientData\fR fields are ignored. .SH "SEE ALSO" Tcl_GetIndexFromObj(3), Tcl_Main(3), Tcl_CreateObjCommand(3) .SH KEYWORDS argument, parse '\" Local Variables: '\" fill-column: 78 '\" End: |
Changes to library/msgcat/doc/ParseCmd.3.
| ︙ | ︙ | |||
190 191 192 193 194 195 196 | \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. | | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. The reference count of the value returned as result has been incremented, so the caller must invoke \fBTcl_DecrRefCount\fR when it is finished with the value. If an error or other exception occurs while evaluating the tokens (such as a reference to a non-existent variable) then the return value is NULL and an error message is left in \fIinterp\fR's result. The use of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, |
| ︙ | ︙ |
Changes to library/msgcat/doc/RecEvalObj.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in Points to a Tcl value containing a command (or sequence of commands) to execute. .AP int flags in An OR'ed combination of flag bits. \fBTCL_NO_EVAL\fR means record the command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .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) that can be retrieved using \fBTcl_GetObjResult\fR. If you do not want the command recorded on the history list then you should invoke \fBTcl_EvalObjEx\fR instead of \fBTcl_RecordAndEvalObj\fR. Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .SH "SEE ALSO" Tcl_EvalObjEx, Tcl_GetObjResult .SH KEYWORDS command, event, execute, history, interpreter, value, record |
Changes to library/msgcat/doc/RecordEval.3.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the | | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the value-based procedure \fBTcl_RecordAndEvalObj\fR. That value-based procedure records and optionally executes a command held in a Tcl value instead of a string. .SH "SEE ALSO" Tcl_RecordAndEvalObj .SH KEYWORDS command, event, execute, history, interpreter, record |
Changes to library/msgcat/doc/RegExp.3.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | .fi .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out | | | | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | .fi .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out Refers to the value from which to get the text to search. The internal representation of the value may be converted to a form that can be efficiently searched. .AP Tcl_Obj *patObj in/out Refers to the value from which to get a regular expression. The compiled regular expression is cached in the value. .AP char *text in Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it operates on the Tcl values \fItextObj\fR and \fIpatObj\fR instead of UTF strings. \fBTcl_RegExpMatchObj\fR is generally more efficient than \fBTcl_RegExpMatch\fR, so it is the preferred interface. .PP \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR provide lower-level access to the regular expression pattern matcher. \fBTcl_RegExpCompile\fR compiles a regular expression string into |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and | | | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and \fBTcl_RegExpGetInfo\fR are value interfaces that provide the most direct control of Henry Spencer's regular expression library. For users that need to modify compilation and execution options directly, it is recommended that you use these interfaces instead of calling the internal regexp functions. These interfaces handle the details of UTF to Unicode translations as well as providing improved performance through caching in the pattern and string values. .PP \fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular expression from the \fIpatObj\fR. If the value does not already contain a compiled regular expression it will attempt to create one from the string in the value and assign it to the internal representation of the \fIpatObj\fR. The return value of this function is of type \fBTcl_RegExp\fR. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR. If an error occurs while compiling the regular expression then \fBTcl_GetRegExpFromObj\fR returns NULL and leaves an error message in the interpreter result. The regular expression token can be used as |
| ︙ | ︙ |
Changes to library/msgcat/doc/SaveResult.3.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | .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 | | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | .PP The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. .PP \fBTcl_SaveResult\fR moves the string and value results of \fIinterp\fR into the location specified by \fIstatePtr\fR. \fBTcl_SaveResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. .PP \fBTcl_RestoreResult\fR moves the string and value results from \fIstatePtr\fR back into \fIinterp\fR. Any result or error that was already in the interpreter will be cleared. The \fIstatePtr\fR is left in an uninitialized state and cannot be used until another call to \fBTcl_SaveResult\fR. .PP \fBTcl_DiscardResult\fR releases the saved interpreter state stored at \fBstatePtr\fR. The state structure is left in an |
| ︙ | ︙ |
Changes to library/msgcat/doc/SetChanErr.3.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | to place arbitrary error messages in \fBbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the | | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | to place arbitrary error messages in \fBbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the specified channel. The number of references to the \fBmsg\fR value goes up by one. Previously stored information will be discarded, by releasing the reference held by the channel. The channel reference must not be NULL. .PP \fBTcl_SetChannelErrorInterp\fR stores error information in the bypass area of the specified interpreter. The number of references to the \fBmsg\fR value goes up by one. Previously stored information will be discarded, by releasing the reference held by the interpreter. The interpreter reference must not be NULL. .PP \fBTcl_GetChannelError\fR places either the error message held in the bypass area of the specified channel into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the channel is now held by the caller of the function and it is its responsibility to release that reference when it is done with the value. .PP \fBTcl_GetChannelErrorInterp\fR places either the error message held in the bypass area of the specified interpreter into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the interpreter is now held by the caller of the function and it is its responsibility to release that reference when it is done with the value. .PP Which functions of a channel driver are allowed to use which bypass function is listed below, as is which functions of the public channel API may leave a messages in the bypass areas. .IP \fBTcl_DriverCloseProc\fR May use \fBTcl_SetChannelErrorInterp\fR, and only this function. .IP \fBTcl_DriverInputProc\fR |
| ︙ | ︙ |
Changes to library/msgcat/doc/SetResult.3.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in Tcl value to become result for \fIinterp\fR. .AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. .AP "const char" *element in String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in |
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | information as well. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. | | | | | | | | | | | | | | | | | | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | information as well. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. The interpreter result may be either a Tcl value or a string. For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR set the interpreter result to, respectively, a value and a string. Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR return the interpreter result as a value and as a string. The procedures always keep the string and value forms of the interpreter result consistent. For example, if \fBTcl_SetObjResult\fR is called to set the result to a value, then \fBTcl_GetStringResult\fR is called, it will return the value's string representation. .PP \fBTcl_SetObjResult\fR arranges for \fIobjPtr\fR to be the result for \fIinterp\fR, replacing any existing result. The result is left pointing to the value referenced by \fIobjPtr\fR. \fIobjPtr\fR's reference count is incremented since there is now a new reference to it from \fIinterp\fR. The reference count for any old result value is decremented and the old result value is freed if no references to it remain. .PP \fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value. The value's reference count is not incremented; if the caller needs to retain a long-term pointer to the value they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR arranges for \fIresult\fR to be the result for the current Tcl command in \fIinterp\fR, replacing any existing result. The \fIfreeProc\fR argument specifies how to manage the storage for the \fIresult\fR argument; it is discussed in the section \fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to an empty string. .PP \fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. If the result was set to a value by a \fBTcl_SetObjResult\fR call, the value form will be converted to a string and returned. If the value's string representation contains null bytes, this conversion will lose information. For this reason, programmers are encouraged to write their code to use the new value API procedures and to call \fBTcl_GetObjResult\fR instead. .PP \fBTcl_ResetResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. If the result is a value, its reference count is decremented and the result is left pointing to an unshared value representing an empty string. If the result is a dynamically allocated string, its memory is free*d and the result is left as a empty string. \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. .PP \fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. |
| ︙ | ︙ | |||
163 164 165 166 167 168 169 | .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR | | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR that manipulate the result as a value can be significantly more efficient. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR argument and it appends that argument to the current result as a proper Tcl list element. |
| ︙ | ︙ | |||
248 249 250 251 252 253 254 | .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS | | | 248 249 250 251 252 253 254 255 | .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS append, command, element, list, value, result, return value, interpreter |
Changes to library/msgcat/doc/SetVar.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in Points to a Tcl value containing the new value for the variable. .AP int flags in OR-ed combination of bits providing additional information. See below for valid values. .AP "const char" *varName in Name of variable. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array. .AP "const char" *newValue in New value for variable, specified as a null-terminated string. A copy of this value is stored in the variable. .AP Tcl_Obj *part1Ptr in Points to a Tcl value containing the variable's name. The name may include a series of \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array variable. .AP Tcl_Obj *part2Ptr in If non-NULL, points to a value containing the name of an element within an array and \fIpart1Ptr\fR must refer to an array variable. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, read, and delete Tcl variables from C code. |
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS | | | 242 243 244 245 246 247 248 249 | If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS array, get variable, interpreter, scalar, set, unset, value, variable |
Changes to library/msgcat/doc/SplitPath.3.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP These procedures have been superseded by the Tcl-value-aware procedures in the \fBFileSystem\fR man page, which are more efficient. .PP These procedures may be used to disassemble and reassemble file paths in a platform independent manner: they provide C-level access to the same functionality as the \fBfile split\fR, \fBfile join\fR, and \fBfile pathtype\fR commands. .PP |
| ︙ | ︙ |
Changes to library/msgcat/doc/StringObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 | .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\e700\e600\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) .AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. .AP int numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. If negative, all characters up to the first null character are used. .AP int index in The index of the Unicode character to return. .AP int first in The index of the first Unicode character in the Unicode range to be returned as a new value. .AP int last in The index of the last Unicode character in the Unicode range to be returned as a new value. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP int limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." is used. .AP "const char" *format in Format control string including % conversion specifiers. .AP int objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE .SH DESCRIPTION .PP The procedures described in this manual entry allow Tcl values to be manipulated as string values. They use the internal representation of the value to store additional information to make the string manipulations more efficient. In particular, they make a series of append operations efficient by allocating extra storage space for the string so that it does not have to be copied for each append. Also, indexing and length computations are optimized because the Unicode string representation is calculated and cached as needed. When using the \fBTcl_Append*\fR family of functions where the interpreter's result is the value being appended to, it is important to call Tcl_ResetResult first to ensure you are not unintentionally appending to existing data in the result value. .PP \fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new value or modify an existing value to hold a copy of the string given by \fIbytes\fR and \fIlength\fR. \fBTcl_NewUnicodeObj\fR and \fBTcl_SetUnicodeObj\fR create a new value or modify an existing value to hold a copy of the Unicode string given by \fIunicode\fR and \fInumChars\fR. \fBTcl_NewStringObj\fR and \fBTcl_NewUnicodeObj\fR return a pointer to a newly created value with reference count zero. All four procedures set the value to hold a copy of the specified string. \fBTcl_SetStringObj\fR and \fBTcl_SetUnicodeObj\fR free any old string representation as well as any old internal representation of the value. .PP \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return a value's string representation. This is given by the returned byte pointer and (for \fBTcl_GetStringFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. If the value's UTF string representation is invalid (its byte pointer is NULL), the string representation is regenerated from the value's internal representation. The storage referenced by the returned byte pointer is owned by the value manager. It is passed back as a writable pointer so that extension author creating their own \fBTcl_ObjType\fR will be able to modify the string representation within the \fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any in-place modification of the string representation. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP \fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return a value's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated from the value's string representation. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. .PP \fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and \fIlength\fR to the string representation of the value specified by \fIobjPtr\fR. If the value has an invalid string representation, then an attempt is made to convert \fIbytes\fR is to the Unicode format. If the conversion is successful, then the converted form of \fIbytes\fR is appended to the value's Unicode representation. Otherwise, the value's Unicode representation is invalidated and converted to the UTF format, and \fIbytes\fR is appended to the value's new string representation. .PP \fBTcl_AppendUnicodeToObj\fR appends the Unicode string given by \fIunicode\fR and \fInumChars\fR to the value specified by \fIobjPtr\fR. If the value has an invalid Unicode representation, then \fIunicode\fR is converted to the UTF format and appended to the value's string representation. Appends are optimized to handle repeated appends relatively efficiently (it over-allocates the string or Unicode space to avoid repeated reallocations and copies of value's string value). .PP \fBTcl_AppendObjToObj\fR is similar to \fBTcl_AppendToObj\fR, but it appends the string or Unicode value (whichever exists and is best suited to be appended to \fIobjPtr\fR) of \fIappendObjPtr\fR to \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR | | | | | | | | | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR argument is greater than the space allocated for the value's string, then the string space is reallocated and the old value is copied to the new space; the bytes between the old length of the string and the new length may have arbitrary values. If the \fInewLength\fR argument is less than the current length of the value's string, with \fIobjPtr->length\fR is reduced without reallocating the string space; the original allocated size for the string is recorded in the value, so that the string length can be enlarged in a subsequent call to \fBTcl_SetObjLength\fR without reallocating storage. In all cases \fBTcl_SetObjLength\fR leaves a null character at \fIobjPtr->bytes[newLength]\fR. .PP \fBTcl_AttemptSetObjLength\fR is identical in function to \fBTcl_SetObjLength\fR except that if sufficient memory to satisfy the request cannot be allocated, it does not cause the Tcl interpreter to \fBpanic\fR. Thus, if \fInewLength\fR is greater than the space allocated for the value's string, and there is not enough memory available to satisfy the request, \fBTcl_AttemptSetObjLength\fR will take no action and return 0 to indicate failure. If there is enough memory to satisfy the request, \fBTcl_AttemptSetObjLength\fR behaves just like \fBTcl_SetObjLength\fR and returns 1 to indicate success. .PP The \fBTcl_ConcatObj\fR function returns a new string value whose value is the space-separated concatenation of the string representations of all of the values in the \fIobjv\fR array. \fBTcl_ConcatObj\fR eliminates leading and trailing white space as it copies the string representations of the \fIobjv\fR array to the result. If an element of the \fIobjv\fR array consists of nothing but white space, then that value is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. .SH "SEE ALSO" Tcl_NewObj(3), Tcl_IncrRefCount(3), Tcl_DecrRefCount(3), format(n), sprintf(3) .SH KEYWORDS append, internal representation, value, value type, string value, string type, string representation, concat, concatenate, unicode |
Changes to library/msgcat/doc/SubstObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" 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_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" 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_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SubstObj \- perform substitutions on Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_SubstObj\fR(\fIinterp, objPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute Tcl scripts and lookup variables. If an error occurs, the interpreter's result is modified to hold an error message. .AP Tcl_Obj *objPtr in A Tcl value containing the string to perform substitutions on. .AP int flags in ORed combination of flag bits that specify which substitutions to perform. The flags \fBTCL_SUBST_COMMANDS\fR, \fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are currently supported, and \fBTCL_SUBST_ALL\fR is provided as a convenience for the common case where all substitutions are desired. .BE .SH DESCRIPTION .PP The \fBTcl_SubstObj\fR function is used to perform substitutions on strings in the fashion of the \fBsubst\fR command. It gets the value of the string contained in \fIobjPtr\fR and scans it, copying characters and performing the chosen substitutions as it goes to an output value which is returned as the result of the function. In the event of an error occurring during the execution of a command or variable substitution, the function returns NULL and an error message is left in \fIinterp\fR's result. .PP Three kinds of substitutions are supported. When the \fBTCL_SUBST_BACKSLASHES\fR bit is set in \fIflags\fR, sequences that look like backslash substitutions for Tcl commands are replaced by |
| ︙ | ︙ |
Changes to library/msgcat/doc/TCL_MEM_DEBUG.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | \fI\-\-enable\-symbols=mem\fR flag to the \fIconfigure\fR script when building). This will also compile in a non-stub version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl. .PP \fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined for all modules that are going to be linked together. If they are not, link errors will occur, with either \fBTcl_DbCkfree\fR and \fBTcl_DbCkalloc\fR or | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | \fI\-\-enable\-symbols=mem\fR flag to the \fIconfigure\fR script when building). This will also compile in a non-stub version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl. .PP \fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined for all modules that are going to be linked together. If they are not, link errors will occur, with either \fBTcl_DbCkfree\fR and \fBTcl_DbCkalloc\fR or \fBTcl_Alloc\fR and \fBTcl_Free\fR being undefined. .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP |
| ︙ | ︙ |
Changes to library/msgcat/doc/TclZlib.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 52 53 | \fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) .sp int \fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) .fi .SH ARGUMENTS | > > | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | \fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) .sp int \fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) .sp \fBTcl_ZlibStreamSetCompressionDictionary\fR(\fIzshandle, compDict\fR) .fi .SH ARGUMENTS .AS Tcl_ZlibStream zshandle in .AP Tcl_Interp *interp in The interpreter to store resulting compressed or uncompressed data in. Also where any error messages are written. For \fBTcl_ZlibStreamInit\fR, this can be NULL to create a stream that is not bound to a command. .AP int format in What format of compressed data to work with. Must be one of \fBTCL_ZLIB_FORMAT_ZLIB\fR for zlib-format data, \fBTCL_ZLIB_FORMAT_GZIP\fR for gzip-format data, or \fBTCL_ZLIB_FORMAT_RAW\fR for raw compressed data. In addition, for decompression only, \fBTCL_ZLIB_FORMAT_AUTO\fR may also be chosen which can automatically detect whether the compressed data was in zlib or gzip format. .AP Tcl_Obj *dataObj in/out A byte-array value containing the data to be compressed or decompressed, or to which the data extracted from the stream is appended when passed to \fBTcl_ZlibStreamGet\fR. .AP int level in What level of compression to use. Should be a number from 0 to 9 or one of the following: \fBTCL_ZLIB_COMPRESS_NONE\fR for no compression, \fBTCL_ZLIB_COMPRESS_FAST\fR for fast but inefficient compression, \fBTCL_ZLIB_COMPRESS_BEST\fR for slow but maximal compression, or |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib library by Jean-loup Gailly and Mark Adler. .PP \fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and decompress the data contained in the \fIdataObj\fR argument, according to the \fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in the \fIdictObj\fR parameter is used to convey additional header information about the compressed data when the compression format supports it; currently, the dictionary is only used when the \fIformat\fR parameter is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section below. Upon success, both functions leave the resulting compressed or | > > > > > > > | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to indicate whether a compression dictionary was present other than to fail on decompression. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib library by Jean-loup Gailly and Mark Adler. .PP \fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and decompress the data contained in the \fIdataObj\fR argument, according to the \fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in the \fIdictObj\fR parameter is used to convey additional header information about the compressed data when the compression format supports it; currently, the dictionary is only used when the \fIformat\fR parameter is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section below. Upon success, both functions leave the resulting compressed or decompressed data in a byte-array value that is the Tcl interpreter's result; the returned value is a standard Tcl result code. .PP \fBTcl_ZlibAdler32\fR and \fBTcl_ZlibCRC32\fR compute checksums on arrays of bytes, returning the computed checksum. Checksums are computed incrementally, allowing data to be processed one block at a time, but this requires the caller to maintain the current checksum and pass it in as the \fIinitValue\fR parameter; the initial value to use for this can be obtained by using NULL for |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | to be thread-safe; each stream should only ever be used from the thread that created it. When working with gzip streams, a dictionary (fields as given in the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the \fIdictObj\fR parameter that on compression allows control over the generated headers, and on decompression allows discovery of the existing headers. Note that the dictionary will be written to on decompression once sufficient data has been read to have a complete header. This means that the dictionary must | | | | > > > > > > > > > > > > > > > > > > > | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | to be thread-safe; each stream should only ever be used from the thread that created it. When working with gzip streams, a dictionary (fields as given in the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the \fIdictObj\fR parameter that on compression allows control over the generated headers, and on decompression allows discovery of the existing headers. Note that the dictionary will be written to on decompression once sufficient data has been read to have a complete header. This means that the dictionary must be an unshared value in that case; a blank value created with \fBTcl_NewObj\fR is suggested. .PP Once a stream has been constructed, \fBTcl_ZlibStreamPut\fR is used to add data to the stream and \fBTcl_ZlibStreamGet\fR is used to retrieve data from the stream after processing. Both return normal Tcl result codes and leave an error message in the result of the interpreter that the stream is registered with in the error case (if such a registration has been performed). With \fBTcl_ZlibStreamPut\fR, the data buffer value passed to it should not be modified afterwards. With \fBTcl_ZlibStreamGet\fR, the data buffer value passed to it will have the data bytes appended to it. Internally to the stream, data is kept compressed so as to minimize the cost of buffer space. .PP \fBTcl_ZlibStreamChecksum\fR returns the checksum computed over the uncompressed data according to the format, and \fBTcl_ZlibStreamEof\fR returns a boolean value indicating whether the end of the uncompressed data has been reached. .PP \fBTcl_ZlibStreamSetCompressionDictionary\fR is used to control the compression dictionary used with the stream, a compression dictionary being an array of bytes (such as might be created with \fBTcl_NewByteArrayObj\fR) that is used to initialize the compression engine rather than leaving it to create it on the fly from the data being compressed. Setting a compression dictionary allows for more efficient compression in the case where the start of the data is highly regular, but it does require both the compressor and the decompressor to agreee on the value to use. Compression dictionaries are only fully supported for zlib-format data; on compression, they must be set before any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its \fB\-errorcode\fR set to .QW "\fBZLIB NEED_DICT\fI code\fR" ; the \fIcode\fR will be the Adler-32 checksum (see \fBTcl_ZlibAdler32\fR) of the compression dictionary sought. (Note that this is only true for zlib-format streams; gzip streams ignore compression dictionaries as the format specification doesn't permit them, and raw streams just produce a data error if the compression dictionary is missing or incorrect.) .PP If you wish to clear a stream and reuse it for a new compression or decompression action, \fBTcl_ZlibStreamReset\fR will do this and return a normal Tcl result code to indicate whether it was successful; if the stream is registered with an interpreter, an error message will be left in the interpreter result when this function returns TCL_ERROR. Finally, \fBTcl_ZlibStreamClose\fR will clean up the stream and delete the associated command: using \fBTcl_DeleteCommand\fR on the stream's command is equivalent (when such a command exists). .SH "GZIP OPTIONS DICTIONARY" .PP The \fIdictObj\fR parameter to \fBTcl_ZlibDeflate\fR, \fBTcl_ZlibInflate\fR and \fBTcl_ZlibStreamInit\fR is used to pass a dictionary of options about that is used to describe the gzip header in the compressed data. When creating compressed data, the dictionary is read and when unpacking compressed data the dictionary is written (in which case the \fIdictObj\fR parameter must refer to an unshared dictionary value). .PP The following fields in the dictionary value are understood. All other fields are ignored. No field is required when creating a gzip-format stream. .TP \fBcomment\fR . This holds the comment field of the header, if present. If absent, no comment was supplied (on decompression) or will be created (on compression). .TP |
| ︙ | ︙ |
Changes to library/msgcat/doc/WrongNumArgs.3.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. .AP int objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in Arguments to command that had the wrong number of arguments. .AP "const char" *message in Additional error information to print after leading arguments from \fIobjv\fR. This typically gives the acceptable syntax of the command. This argument may be NULL. .BE .SH DESCRIPTION .PP \fBTcl_WrongNumArgs\fR is a utility procedure that is invoked by command procedures when they discover that they have received the wrong number of arguments. \fBTcl_WrongNumArgs\fR generates a standard error message and stores it in the result value of \fIinterp\fR. The message includes the \fIobjc\fR initial elements of \fIobjv\fR plus \fImessage\fR. For example, if \fIobjv\fR consists of the values \fBfoo\fR and \fBbar\fR, \fIobjc\fR is 1, and \fImessage\fR is .QW "\fBfileName count\fR" then \fIinterp\fR's result value will be set to the following string: .PP .CS wrong # args: should be "foo fileName count" .CE .PP If \fIobjc\fR is 2, the result will be set to the following string: .PP .CS wrong # args: should be "foo bar fileName count" .CE .PP \fIObjc\fR is usually 1, but may be 2 or more for commands like \fBstring\fR and the Tk widget commands, which use the first argument as a subcommand. .PP Some of the values in the \fIobjv\fR array may be abbreviations for a subcommand. The command \fBTcl_GetIndexFromObj\fR will convert the abbreviated string value into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any \fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand name in the error message instead of the abbreviated name that was originally passed in. Using the above example, let us assume that \fIbar\fR is actually an abbreviation for \fIbarfly\fR and the value is now an \fIindexObject\fR because it was passed to \fBTcl_GetIndexFromObj\fR. In this case the error message would be: .PP .CS wrong # args: should be "foo barfly fileName count" .CE .SH "SEE ALSO" Tcl_GetIndexFromObj(3) .SH KEYWORDS command, error message, wrong number of arguments |
Changes to library/msgcat/doc/dde.n.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the 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 | | > > | | | > > > | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the 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 . \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, \fIservice\fR is the name of an application. \fItopic\fR is application 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 . \fBdde request\fR is typically used to get the value of something; the value of a cell in Microsoft Excel or the text of a selection in Microsoft Word. \fIservice\fR is typically the name of an application, |
| ︙ | ︙ |
Changes to library/msgcat/doc/define.n.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . .TP | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . .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 |
| ︙ | ︙ |
Changes to library/msgcat/doc/dict.n.
| ︙ | ︙ | |||
142 143 144 145 146 147 148 149 150 151 152 153 154 155 | . This appends the given items to the list value that the given 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 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. .TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . Return a dictionary that contains the contents of each of the \fIdictionaryValue\fR arguments. Where two (or more) dictionaries contain a mapping for the same key, the resulting dictionary maps that key to the value according to the last dictionary on the command line | > > > > > > > > > > > > > > > > > > > > > > > > > | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
.
This appends the given items to the list value that the given 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 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.
.TP
\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
returning a new dictionary. It takes three arguments: the first is a
two-element list of variable names (for the key and value respectively of each
mapping in the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key and value
variables set appropriately (in the manner of \fBlmap\fR). In an iteration
where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an
\fBerror\fR, etc.) the result of the script is put into an accumulator
dictionary using the key that is the current contents of the \fIkeyVar\fR
variable at that point. The result of the \fBdict map\fR command is the
accumulator dictionary after all keys have been iterated over.
.RS
.PP
If the evaluation of the body for any particular step generates a \fBbreak\fR,
no further pairs from the dictionary will be iterated over and the \fBdict
map\fR command will terminate successfully immediately. If the evaluation of
the body for a particular step generates a \fBcontinue\fR result, the current
iteration is aborted and the accumulator dictionary is not modified. The order
of iteration is the natural order of the dictionary (typically the order in
which the keys were added to the dictionary; the order is the same as that
used in \fBdict for\fR).
.RE
.TP
\fBdict merge \fR?\fIdictionaryValue ...\fR?
.
Return a dictionary that contains the contents of each of the
\fIdictionaryValue\fR arguments. Where two (or more) dictionaries
contain a mapping for the same key, the resulting dictionary maps that
key to the value according to the last dictionary on the command line
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
.CS
set foo {foo {a b} bar 2 baz 3}
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
| | | | 429 430 431 432 433 434 435 436 437 438 439 440 441 |
.CS
set foo {foo {a b} bar 2 baz 3}
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
.SH KEYWORDS
dictionary, create, update, lookup, iterate, filter, map
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to library/msgcat/doc/expr.n.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | 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 additional operators not found in C. .SS OPERANDS .PP A Tcl expression consists of a combination of operands, operators, | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | 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 additional operators not found in C. .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, |
| ︙ | ︙ | |||
278 279 280 281 282 283 284 285 286 287 288 289 290 291 | .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). .PP See the \fBmathfunc\fR(n) manual page 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 | > > > > > > > > > > > > | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
.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).
.PP
Some mathematical functions have several arguments, separated by commas like in C. Thus:
.PP
.CS
\fBexpr\fR {hypot($x,$y)}
.CE
.PP
ends up as
.PP
.CS
tcl::mathfunc::hypot $x $y
.CE
.PP
See the \fBmathfunc\fR(n) manual page 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
|
| ︙ | ︙ |
Changes to library/msgcat/doc/fconfigure.n.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input or output. \fINewvalue\fR must be between one and one million, allowing buffers of one to one million bytes in size. .TP \fB\-encoding\fR \fIname\fR . This option is used to specify the encoding of the channel, so that the data can be converted to and from Unicode for use in Tcl. For instance, in order for Tcl to read characters from a Japanese file in \fBshiftjis\fR and properly process and display the contents, the encoding would be set |
| ︙ | ︙ |
Changes to library/msgcat/doc/fileevent.n.
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP | | | | | | > > > | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP Event-driven I/O works best for channels that have been placed into nonblocking mode with the \fBfconfigure\fR command. In blocking mode, a \fBputs\fR command may block if you give it more data than the underlying file or device can accept, and a \fBgets\fR or \fBread\fR command will block if you attempt to read more data than is ready; a readable underlying file or device may not even guarantee that a blocking [read 1] will succeed (counter-examples being multi-byte encodings, compression or encryption transforms ). In all such cases, no events will be processed while the commands block. .PP In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. See the documentation for the individual commands for information on how they handle blocking and nonblocking channels. .PP Testing for the end of file condition should be done after any attempts read the channel data. The eof flag is set once an attempt to read the end of data has occurred and testing before this read will require an |
| ︙ | ︙ |
Changes to library/msgcat/doc/load.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName\fR .br \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName\fR .br \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName interp\fR .BE .SH DESCRIPTION .PP This command loads binary code from a file into the application's address space and calls an initialization procedure in the package to incorporate it into an interpreter. \fIfileName\fR is the name of the file containing the code; its exact form varies |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 | The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with .QW "library not found" error, it is also possible | > > > > > > > > > > > > > > > > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .PP If \fB\-global\fR is specified preceding the filename, all symbols found in the shared library are exported for global use by other libraries. The option \fB\-lazy\fR delays the actual loading of symbols until their first actual use. The options may be abbreviated. The option \fB\-\-\fR indicates the end of the options, and should be used if you wish to use a filename which starts with \fB\-\fR and you provide a packageName to the \fBload\fR command. .PP On platforms which do not support the \fB\-global\fR or \fB\-lazy\fR options, the options still exist but have no effect. Note that use of the \fB\-global\fR or \fB\-lazy\fR option may lead to crashes in your application later (in case of symbol conflicts resp. missing symbols), which cannot be detected during the \fBload\fR. So, only use this when you know what you are doing, you will not get a nice error message when something is wrong with the loaded library. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with .QW "library not found" error, it is also possible |
| ︙ | ︙ |
Changes to library/msgcat/doc/msgcat.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros | | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" 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 "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp \fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp \fB::msgcat::mcpreferences\fR .sp \fB::msgcat::mcload \fIdirname\fR .sp \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp .VS "TIP 404" \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcflmset \fIsrc-trans-list\fR .VE "TIP 404" .sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
| > > > > > > > > > > > > > > > > > > > > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR?
.VS "TIP 404"
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the
current namespace for the locale implied by the name of the message catalog
being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not
specified, \fIsrc-string\fR is used for both. The function returns
\fItranslate-string\fR.
.VE "TIP 404"
.TP
\fB::msgcat::mcflmset \fIsrc-trans-list\fR
.VS "TIP 404"
Sets the translation for multiple source strings in \fIsrc-trans-list\fR in
the current namespace for the locale implied by the name of the message
catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must
have an even number of elements and is in the form {\fIsrc-string
translate-string\fR ?\fIsrc-string translate-string ...\fR?}
\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations
of \fB::msgcat::mcflset\fR. The function returns the number of translations set.
.VE "TIP 404"
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP | | | > > > > | | < | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. From Windows Vista on, the RFC4747 locale name "lang-script-country-options" is transformed to the locale as "lang_country_script" (Example: sr-Latn-CS -> sr_cs_latin). For Windows XP, the language id is transformed analoguously (Example: 0c1a -> sr_yu_cyrillic). If all these attempts to discover an initial locale from the user's environment fail, msgcat defaults to an initial locale of .QW C . .PP When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user specifies en_GB_Funky, the locales |
| ︙ | ︙ | |||
279 280 281 282 283 284 285 | is called .QW \fBROOT.msg\fR . This exception is made so as not to cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. .IP [3] | | | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
is called
.QW \fBROOT.msg\fR .
This exception is made so as not to
cause peculiar behavior, such as marking the message file as
.QW hidden
on Unix file systems.
.IP [3]
The file contains a series of calls to \fBmcflset\fR and
\fBmcflmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.PP
.CS
namespace eval ::mypackage {
\fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!"
}
.CE
.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
|
| ︙ | ︙ |
Changes to library/msgcat/doc/next.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" 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 next n 0.1 TclOO "TclOO Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" 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 next n 0.1 TclOO "TclOO Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME next, nextto \- invoke superclass method implementations .SH SYNOPSIS .nf package require TclOO \fBnext\fR ?\fIarg ...\fR? \fBnextto\fI class\fR ?\fIarg ...\fR? .fi |
| ︙ | ︙ |
Changes to library/msgcat/doc/string.n.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: | < < < < < < < < < < < < < < < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically less than, equal to, or greater than \fIstring2\fR. If \fB\-length\fR is specified, then only the |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 | | > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 Any Unicode whitespace character, zero width space (U+200b), word joiner (U+2060) and zero width no-break space (U+feff) (=BOM). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional |
| ︙ | ︙ | |||
194 195 196 197 198 199 200 | will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR . Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the | | | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR . Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the number of bytes used to store the string. If the value is a byte array value (such as those returned from reading a binary encoded channel), then this will return the actual byte length of the value. .TP \fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR . Replaces substrings in \fIstring\fR based on the key-value pairs in \fImapping\fR. \fImapping\fR is a list of \fIkey value key value ...\fR as in the form returned by \fBarray get\fR. Each instance of a key in the string will be replaced with its corresponding value. If |
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .SS "OBSOLETE SUBCOMMANDS" .PP These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. .TP \fBstring bytelength \fIstring\fR . Returns a decimal string giving the number of bytes used to represent \fIstring\fR in memory. Because UTF\-8 uses one to three bytes to represent Unicode characters, the byte length will not be the same as the character length in general. The cases where a script cares about the byte length are rare. .RS .PP In almost all cases, you should use the \fBstring length\fR operation (including determining the length of a Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. .PP \fICompatibility note:\fR it is likely that this subcommand will be withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. .RE .TP \fBstring wordend \fIstring charIndex\fR . Returns the index of the character just after the last one in the word containing character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be specified using the forms in \fBSTRING INDICES\fR. A word is considered to be any contiguous range of alphanumeric (Unicode letters |
| ︙ | ︙ |
Changes to library/msgcat/doc/tclsh.1.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS \fBtclsh\fR ?\fB\-encoding \fIname\fR? ?\fIfileName arg arg ...\fR? .BE .SH DESCRIPTION .PP \fBTclsh\fR is a shell-like application that reads Tcl commands from its standard input or from a file and evaluates them. If invoked with no arguments then it runs interactively, reading Tcl commands from standard input and printing command results and |
| ︙ | ︙ |
Changes to library/msgcat/doc/trace.n.
| ︙ | ︙ | |||
139 140 141 142 143 144 145 | course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .PP .CS | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .PP .CS \fIcommandPrefix command-string code result op\fR .CE .PP \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an arbitrary command for a \fBenterstep\fR operation), including all arguments in their fully expanded form. \fICode\fR gives the result code of that execution, and \fIresult\fR |
| ︙ | ︙ |
Changes to library/msgcat/doc/zlib.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2008-2012 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH zlib n 8.6 Tcl "Tcl Built-In Commands" .BS |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). | > > > > > > > | | < > | | > > | | > > > > > > > > > > > > > > > > < < < < < < < < | > > > > > > > > | | | | > > > | > > > > | | > > > > > | | | | > > > > > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. Not valid for transformations that work with gzip-format data. .VE .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . The maximum number of bytes ahead to read when decompressing. This defaults to 1, which ensures that data is always decompressed correctly, but may be increased to improve performance. This is more useful when the channel is non-blocking. .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: .TP \fB\-checksum\fI checksum\fR . This read-only option gets the current checksum for the uncompressed data that the compression engine has seen so far. It is valid for both compressing and decompressing transforms, but not for the raw inflate and deflate formats. The compression algorithm depends on what format is being produced or consumed. .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" This read-write options gets or sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. It is not valid for transformations that work with gzip-format data, and should not normally be set on compressing transformations other than at the point where the transformation is stacked. .VE .TP \fB\-flush\fI type\fR . This write-only operation flushes the current state of the compressor to the underlying channel. It is only valid for compressing transformations. The \fItype\fR must be either \fBsync\fR or \fBfull\fR for a normal flush or an expensive flush respectively. Flushing degrades the compression ratio, but makes it easier for a decompressor to recover more of the file in the case of data corruption. .TP \fB\-header\fI dictionary\fR . This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the maximum number of bytes ahead to read from the underlying data source. This defaults to 1, which ensures that data is always decompressed correctly, but may be increased to improve performance. This is more useful when the channel is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes and \fIoptions\fR are supported: .RS .TP \fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, .VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). .VE .TP \fBzlib stream decompress\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. .VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use if required. .VE .TP \fBzlib stream deflate\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, .VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). Note that the raw compressed data includes no metadata about what compression dictionary was used, if any; that is a feature of the zlib-format data. .VE .TP \fBzlib stream gunzip\fR . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. .TP \fBzlib stream gzip\fR ?\fB\-header \fIheader\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces gzip-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, and the header descriptor dictionary \fIheader\fR (if specified; for keys see \fBzlib gzip\fR). .TP \fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and produces uncompressed output. .VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that there are no checks in place to determine whether the compression dictionary is correct. .VE .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP \fBzlib adler32\fI string\fR ?\fIinitValue\fR? . Compute a checksum of binary string \fIstring\fR using the Adler-32 algorithm. If given, \fIinitValue\fR is used to initialize the checksum engine. |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | command. They are used by calling their \fBput\fR subcommand one or more times to load data in, and their \fBget\fR subcommand one or more times to extract the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP | | | | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | command. They are used by calling their \fBput\fR subcommand one or more times to load data in, and their \fBget\fR subcommand one or more times to extract the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP \fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR . A short-cut for .QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" followed by .QW "\fIstream \fBget\fR" . .TP \fIstream \fBchecksum\fR . Returns the checksum of the uncompressed data seen so far by this stream. .TP |
| ︙ | ︙ | |||
314 315 316 317 318 319 320 321 |
.QW "\fIstream \fBput \-fullflush {}\fR" .
.TP
\fIstream \fBget \fR?\fIcount\fR?
.
Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the
transformation applied. If \fIcount\fR is omitted, the entire contents of the
buffers are returned.
.TP
| > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
.QW "\fIstream \fBput \-fullflush {}\fR" .
.TP
\fIstream \fBget \fR?\fIcount\fR?
.
Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the
transformation applied. If \fIcount\fR is omitted, the entire contents of the
buffers are returned.
.
\fIstream \fBheader\fR
.
Return the gzip header description dictionary extracted from the stream. Only
supported for streams created with their \fImode\fR parameter set to
\fBgunzip\fR.
.TP
\fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR
.
Append the contents of the binary string \fIdata\fR to \fIstream\fR's internal
buffers while applying the transformation. The following \fIoption\fRs are
supported (or an unambiguous prefix of them), which are used to modify the
way in which the transformation is applied:
.RS
.TP
\fB\-dictionary\fI binData\fR
.VS "TIP 400"
Sets the compression dictionary to use when working with compressing or
decompressing the data to be \fIbinData\fR.
.VE
.TP
\fB\-finalize\fR
.
Mark the stream as finished, ensuring that all bytes have been wholly
compressed or decompressed. For gzip streams, this also ensures that the
footer is written to the stream. The stream will need to be reset before
having more data written to it after this, though data can still be read out
of the stream with the \fBget\fR subcommand.
.RS
.PP
This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR
options.
.RE
.TP
\fB\-flush\fR
.
Ensure that a decompressor consuming the bytes that the current (compressing)
stream is producing will be able to produce all the bytes that have been
compressed so far, at some performance penalty.
.RS
.PP
This option is mutually exclusive with the \fB\-finalize\fR and
\fB\-fullflush\fR options.
.RE
.TP
\fB\-fullflush\fR
.
Ensure that not only can a decompressor handle all the bytes produced so far
(as with \fB\-flush\fR above) but also that it can restart from this point if
it detects that the stream is partially corrupt. This incurs a substantial
performance penalty.
.RS
.PP
This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR
options.
.RE
.RE
.TP
\fIstream \fBreset\fR
.
Puts any stream, including those that have been finalized or that have reached
eof, back into a state where it can process more data. Throws away all
internally buffered data.
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | $\fIstrm \fBfinalize\fR set compData [$\fIstrm \fBget\fR] $\fIstrm \fBclose\fR .CE .SH "SEE ALSO" binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 .SH "KEYWORDS" | | | 450 451 452 453 454 455 456 457 458 459 460 | $\fIstrm \fBfinalize\fR set compData [$\fIstrm \fBget\fR] $\fIstrm \fBclose\fR .CE .SH "SEE ALSO" binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 .SH "KEYWORDS" compress, decompress, deflate, gzip, inflate, zlib '\" Local Variables: '\" mode: nroff '\" End: |
Changes to library/msgcat/msgcat.tcl.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. | | | > > > | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
#
# 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
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.5.0
namespace eval msgcat {
namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
mcunknown mcflset mcflmset
# Records the current locale as passed to mclocale
variable Locale ""
# Records the list of locales to search
variable Loclist {}
# Records the locale of the currently sourced message catalogue file
variable FileLocale
# Records the mapping between source strings and translated strings. The
# dict key is of the form "<locale> <namespace> <src>", where locale and
# namespace should be themselves dict values and the value is
# the translated string.
variable Msgs [dict create]
# Map of language codes used in Windows registry to those of ISO-639
if {[info sharedlibextension] eq ".dll"} {
variable WinRegToISO639 [dict create {*}{
01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
4001 ar_QA
02 bg 0402 bg_BG
03 ca 0403 ca_ES
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | 11 ja 0411 ja_JP 12 ko 0412 ko_KR 13 nl 0413 nl_NL 0813 nl_BE 14 no 0414 no_NO 0814 nn_NO 15 pl 0415 pl_PL 16 pt 0416 pt_BR 0816 pt_PT 17 rm 0417 rm_CH | | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | 11 ja 0411 ja_JP 12 ko 0412 ko_KR 13 nl 0413 nl_NL 0813 nl_BE 14 no 0414 no_NO 0814 nn_NO 15 pl 0415 pl_PL 16 pt 0416 pt_BR 0816 pt_PT 17 rm 0417 rm_CH 18 ro 0418 ro_RO 0818 ro_MO 19 ru 0819 ru_MO 1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic 1b sk 041b sk_SK 1c sq 041c sq_AL 1d sv 041d sv_SE 081d sv_FI 1e th 041e th_TH 1f tr 041f tr_TR 20 ur 0420 ur_PK 0820 ur_IN |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 95 96 97 98 99 100 101 | 2b hy 042b hy_AM 2c az 042c az_AZ@latin 082c az_AZ@cyrillic 2d eu 2e wen 042e wen_DE 2f mk 042f mk_MK 30 bnt 0430 bnt_TZ 31 ts 0431 ts_ZA 33 ven 0433 ven_ZA 34 xh 0434 xh_ZA 35 zu 0435 zu_ZA 36 af 0436 af_ZA 37 ka 0437 ka_GE 38 fo 0438 fo_FO 39 hi 0439 hi_IN | > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | 2b hy 042b hy_AM 2c az 042c az_AZ@latin 082c az_AZ@cyrillic 2d eu 2e wen 042e wen_DE 2f mk 042f mk_MK 30 bnt 0430 bnt_TZ 31 ts 0431 ts_ZA 32 tn 33 ven 0433 ven_ZA 34 xh 0434 xh_ZA 35 zu 0435 zu_ZA 36 af 0436 af_ZA 37 ka 0437 ka_GE 38 fo 0438 fo_FO 39 hi 0439 hi_IN |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
# Arguments:
# langdir The directory to search.
#
# Results:
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
set x 0
foreach p [mcpreferences] {
if { $p eq {} } {
set p ROOT
}
set langfile [file join $langdir $p.msg]
if {[file exists $langfile]} {
incr x
uplevel 1 [list ::source -encoding utf-8 $langfile]
}
}
return $x
}
# msgcat::mcset --
#
# Set the translation for a given string in a specified locale.
| > > > > > > > > > > > > > | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
# Arguments:
# langdir The directory to search.
#
# Results:
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
variable FileLocale
# Save the file locale if we are recursively called
if {[info exists FileLocale]} {
set nestedFileLocale $FileLocale
}
set x 0
foreach p [mcpreferences] {
if { $p eq {} } {
set p ROOT
}
set langfile [file join $langdir $p.msg]
if {[file exists $langfile]} {
incr x
set FileLocale [string tolower [file tail [file rootname $langfile]]]
if {"root" eq $FileLocale} {
set FileLocale ""
}
uplevel 1 [list ::source -encoding utf-8 $langfile]
unset FileLocale
}
}
if {[info exists nestedFileLocale]} {
set FileLocale $nestedFileLocale
}
return $x
}
# msgcat::mcset --
#
# Set the translation for a given string in a specified locale.
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
set ns [uplevel 1 [list ::namespace current]]
set locale [string tolower $locale]
dict set Msgs $locale $ns $src $dest
return $dest
}
# msgcat::mcmset --
#
# Set the translation for multiple strings in a specified locale.
#
# Arguments:
# locale The locale to use.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 |
set ns [uplevel 1 [list ::namespace current]]
set locale [string tolower $locale]
dict set Msgs $locale $ns $src $dest
return $dest
}
# msgcat::mcflset --
#
# Set the translation for a given string in the current file locale.
#
# Arguments:
# src The source string.
# dest (Optional) The translated string. If omitted,
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcflset {src {dest ""}} {
variable FileLocale
variable Msgs
if {![info exists FileLocale]} {
return -code error \
"must only be used inside a message catalog loaded with ::msgcat::mcload"
}
if {[llength [info level 0]] == 2} { ;# dest not specified
set dest $src
}
set ns [uplevel 1 [list ::namespace current]]
dict set Msgs $FileLocale $ns $src $dest
return $dest
}
# msgcat::mcmset --
#
# Set the translation for multiple strings in a specified locale.
#
# Arguments:
# locale The locale to use.
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
should be \"[lindex [info level 0] 0] locale {src dest ...}\""
}
set locale [string tolower $locale]
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
| | > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
should be \"[lindex [info level 0] 0] locale {src dest ...}\""
}
set locale [string tolower $locale]
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
dict set Msgs $locale $ns $src $dest
}
return [expr {$length / 2}]
}
# msgcat::mcflmset --
#
# Set the translation for multiple strings in the mc file locale.
#
# Arguments:
# pairs One or more src/dest pairs (must be even length)
#
# Results:
# Returns the number of pairs processed
proc msgcat::mcflmset {pairs} {
variable FileLocale
variable Msgs
if {![info exists FileLocale]} {
return -code error \
"must only be used inside a message catalog loaded with ::msgcat::mcload"
}
set length [llength $pairs]
if {$length % 2} {
return -code error "bad translation list:\
should be \"[lindex [info level 0] 0] locale {src dest ...}\""
}
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
dict set Msgs $FileLocale $ns $src $dest
}
return [expr {$length / 2}]
}
# msgcat::mcunknown --
#
# This routine is called by msgcat::mc if a translation cannot
# be found for a string. This routine is intended to be replaced
# by an application specific routine for error reporting
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
# Results:
# Returns the length of the longest translated string.
proc msgcat::mcmax {args} {
set max 0
foreach string $args {
set translated [uplevel 1 [list [namespace origin mc] $string]]
| | | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
# Results:
# Returns the length of the longest translated string.
proc msgcat::mcmax {args} {
set max 0
foreach string $args {
set translated [uplevel 1 [list [namespace origin mc] $string]]
set len [string length $translated]
if {$len>$max} {
set max $len
}
}
return $max
}
# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
proc msgcat::ConvertLocale {value} {
|
| ︙ | ︙ | |||
422 423 424 425 426 427 428 |
append ret _$modifier
}
return $ret
}
# Initialize the default locale
proc msgcat::Init {} {
| | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
append ret _$modifier
}
return $ret
}
# Initialize the default locale
proc msgcat::Init {} {
global env
#
# set default locale, try to get from environment
#
foreach varName {LC_ALL LC_MESSAGES LANG} {
if {[info exists env($varName)] && ("" ne $env($varName))} {
if {![catch {
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
if {![catch {
mclocale [ConvertLocale $::tcl::mac::locale]
}]} {
return
}
}
#
| | | | > | | | | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
if {![catch {
mclocale [ConvertLocale $::tcl::mac::locale]
}]} {
return
}
}
#
# The rest of this routine is special processing for Windows or
# Cygwin. All other platforms, get out now.
#
if {([info sharedlibextension] ne ".dll")
|| [catch {package require registry}]} {
mclocale C
return
}
#
# On Windows or Cygwin, try to set locale depending on registry
# settings, or fall back on locale of "C".
#
# First check registry value LocalName present from Windows Vista
# which contains the local string as RFC5646, composed of:
# [a-z]{2,3} : language
# -[a-z]{4} : script (optional, translated by table Latn->latin)
# -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used)
# (-.*)* : variant, extension, private use (optional, not used)
# Those are translated to local strings.
# Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es
#
set key {HKEY_CURRENT_USER\Control Panel\International}
if {([registry values $key "LocaleName"] ne "")
&& [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\
[string tolower [registry get $key "LocaleName"]] match locale\
script territory]} {
if {"" ne $territory} {
append locale _ $territory
}
set modifierDict [dict create latn latin cyrl cyrillic]
if {[dict exists $modifierDict $script]} {
append locale @ [dict get $modifierDict $script]
}
if {![catch {
mclocale [ConvertLocale $locale]
}]} {
return
}
}
# then check key locale which contains a numerical language ID
if {[catch {
set locale [registry get $key "locale"]
}]} {
mclocale C
return
}
#
# 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
# more precise information, such as territory. For example,
|
| ︙ | ︙ |
Changes to library/msgcat/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]]
|
Changes to library/msgcat/tests/assocd.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
} ""
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
} ""
|
| ︙ | ︙ |
Changes to library/msgcat/tests/async.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
|
| ︙ | ︙ |
Changes to library/msgcat/tests/basic.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#
# 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::*
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#
# 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
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/binary.test.
| ︙ | ︙ | |||
2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
test binary-73.23 {binary decode base64} -body {
set r [binary decode base64 YWJj]
list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
string length [binary decode base64 " "]
} -result 0
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
| > > > > > > > > > > > > > > > > > > > > > | 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 |
test binary-73.23 {binary decode base64} -body {
set r [binary decode base64 YWJj]
list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
string length [binary decode base64 " "]
} -result 0
test binary-73.25 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==\n]]] $r
} -result {1 X}
test binary-73.26 {binary decode base64} -body {
list [string length [set r [binary decode base64 WFk=\n]]] $r
} -result {2 XY}
test binary-73.27 {binary decode base64} -body {
list [string length [set r [binary decode base64 WFla\n]]] $r
} -result {3 XYZ}
test binary-73.28 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WA==\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/chan.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
chan configure stdout -eofchar [list \x27 {}]
} -returnCodes ok -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
chan configure stdout -eofchar [list \x27 {}]
} -returnCodes ok -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
test chan-6.1 {chan command: eof subcommand} -body {
chan eof foo bar
|
| ︙ | ︙ |
Changes to library/msgcat/tests/chanio.test.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
| > > > | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
variable f
variable i
variable n
variable v
variable msg
variable expected
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport 0
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
|
| ︙ | ︙ |
Changes to library/msgcat/tests/clock.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
| < < | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
package require registry
}]} {
namespace eval ::tcl::clock {variable NoRegistry {}}
}
}
package require msgcat 1.4
|
| ︙ | ︙ |
Changes to library/msgcat/tests/cmdAH.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
([string index $tcl_platform(osVersion) 0] >= 5
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
([string index $tcl_platform(osVersion) 0] >= 5
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch foo bar baz spaz
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd foo bar
} -result {wrong # args: should be "cd ?dirName?"}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} -setup {
file delete -force $foodir
| > > > > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch foo bar baz spaz
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.4 {Bug 3595576} {
catch {catch {} -> noSuchNs::var}
} 1
test cmdAH-1.5 {Bug 3595576} {
catch {catch error -> noSuchNs::var}
} 1
test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd foo bar
} -result {wrong # args: should be "cd ?dirName?"}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} -setup {
file delete -force $foodir
|
| ︙ | ︙ |
Changes to library/msgcat/tests/cmdIL.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/cmdInfo.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/compExpr-old.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
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]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/compExpr.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Constrain memory leak tests
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Constrain memory leak tests
|
| ︙ | ︙ |
Changes to library/msgcat/tests/compile.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # # 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::* testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. | > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # # 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 catch [list package require -exact Tcltest [info patchlevel]] testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. |
| ︙ | ︙ |
Changes to library/msgcat/tests/coroutine.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
|
| ︙ | ︙ |
Changes to library/msgcat/tests/dcall.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
testdcall
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
testdcall
|
| ︙ | ︙ |
Changes to library/msgcat/tests/dict.test.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
test dict-3.3 {dict get command} {dict get {a b c d} c} d
test dict-3.4 {dict get command} -returnCodes error -body {
dict get {a b c d} b
} -result {key "b" not known in dictionary}
| > > > > > > > > > > > > > > > > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
test dict-2.9 {dict create command: compilation} {
apply {{} {dict create [format a] b}}
} {a b}
test dict-2.10 {dict create command: compilation} {
apply {{} {dict create [format a] b c d}}
} {a b c d}
test dict-2.11 {dict create command: compilation} {
apply {{} {dict create [format a] b c d a x}}
} {a x c d}
test dict-2.12 {dict create command: non-compilation} {
dict create [format a] b
} {a b}
test dict-2.13 {dict create command: non-compilation} {
dict create [format a] b c d
} {a b c d}
test dict-2.14 {dict create command: non-compilation} {
dict create [format a] b c d a x
} {a x c d}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
test dict-3.3 {dict get command} {dict get {a b c d} c} d
test dict-3.4 {dict get command} -returnCodes error -body {
dict get {a b c d} b
} -result {key "b" not known in dictionary}
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 784 785 786 787 788 789 790 |
unset -nocomplain dictVar
} -body {
set dictVar(block) {}
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-17.1 {dict filter command: key} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict filter $dictVar key a2
} -cleanup {
unset dictVar
} -result {a2 b}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
unset -nocomplain dictVar
} -body {
set dictVar(block) {}
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {can't set "dictVar": variable is array}
# Now test with an LVT present (i.e., the bytecoded version).
test dict-16.10 {dict unset command} -body {
apply {{} {
set dictVar {a b c d}
dict unset dictVar a
}}
} -result {c d}
test dict-16.11 {dict unset command} -body {
apply {{} {
set dictVar {a b c d}
dict unset dictVar c
}}
} -result {a b}
test dict-16.12 {dict unset command} -body {
apply {{} {
set dictVar {a b}
dict unset dictVar c
}}
} -result {a b}
test dict-16.13 {dict unset command} -body {
apply {{} {
set dictVar {a {b c d e}}
dict unset dictVar a b
}}
} -result {a {d e}}
test dict-16.14 {dict unset command} -returnCodes error -body {
apply {{} {
set dictVar a
dict unset dictVar a
}}
} -result {missing value to go with key}
test dict-16.15 {dict unset command} -returnCodes error -body {
apply {{} {
set dictVar {a b}
dict unset dictVar c d
}}
} -result {key "c" not known in dictionary}
test dict-16.16 {dict unset command} -body {
apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}}
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
apply {{} {dict unset dictVar}}
} -result {wrong # args: should be "dict unset varName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
apply {{} {
set dictVar(block) {}
dict unset dictVar a
}}
} -returnCodes error -result {can't set "dictVar": variable is array}
test dict-17.1 {dict filter command: key} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict filter $dictVar key a2
} -cleanup {
unset dictVar
} -result {a2 b}
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
} {a x c y}
test dict-20.9 {dict merge command} {
dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 |
} {a x c y}
test dict-20.9 {dict merge command} {
dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
test dict-20.11 {dict merge command} {
apply {{} {dict merge}}
} {}
test dict-20.12 {dict merge command} {
apply {{} {dict merge {a b c d e f}}}
} {a b c d e f}
test dict-20.13 {dict merge command} -body {
apply {{} {dict merge {a b c d e}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.14 {dict merge command} {
apply {{} {dict merge {a b c d} {e f g h}}}
} {a b c d e f g h}
test dict-20.15 {dict merge command} -body {
apply {{} {dict merge {a b c d e} {e f g h}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.16 {dict merge command} -body {
apply {{} {dict merge {a b c d} {e f g h i}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.17 {dict merge command} {
apply {{} {dict merge {a b c d e f} {e x g h}}}
} {a b c d e x g h}
test dict-20.18 {dict merge command} {
apply {{} {dict merge {a b c d} {a x c y}}}
} {a x c y}
test dict-20.19 {dict merge command} {
apply {{} {dict merge {a b c d} {c y a x}}}
} {a x c y}
test dict-20.20 {dict merge command} {
apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 |
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
dict map
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
dict map x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
dict map x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
dict map x x x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
dict map x x x
} -result {must have exactly two variable names}
test dict-24.6 {dict map command: syntax} -returnCodes error -body {
dict map {x x x} x x
} -result {must have exactly two variable names}
test dict-24.7 {dict map command: syntax} -returnCodes error -body {
dict map "\{x" x x
} -result {unmatched open brace in list}
test dict-24.8 {dict map command} -setup {
set values {}
set keys {}
} -body {
# This test confirms that [dict keys], [dict values] and [dict map]
# all traverse a dictionary in the same order.
set dictv {a A b B c C}
dict map {k v} $dictv {
lappend keys $k
lappend values $v
}
set result [expr {
$keys eq [dict keys $dictv] && $values eq [dict values $dictv]
}]
expr {$result ? "YES" : [list "NO" $dictv $keys $values]}
} -cleanup {
unset result keys values k v dictv
} -result YES
test dict-24.9 {dict map command} {
dict map {k v} {} {
error "unexpected execution of 'dict map' body"
}
} {}
test dict-24.10 {dict map command: script results} -body {
set times 0
dict map {k v} {a a b b} {
incr times
continue
error "shouldn't get here"
}
return $times
} -cleanup {
unset times k v
} -result 2
test dict-24.11 {dict map command: script results} -body {
set times 0
dict map {k v} {a a b b} {
incr times
break
error "shouldn't get here"
}
return $times
} -cleanup {
unset times k v
} -result 1
test dict-24.12 {dict map command: script results} -body {
set times 0
list [catch {
dict map {k v} {a a b b} {
incr times
error test
}
} msg] $msg $times $::errorInfo
} -cleanup {
unset times k v msg
} -result {1 test 1 {test
while executing
"error test"
("dict map" body line 3)
invoked from within
"dict map {k v} {a a b b} {
incr times
error test
}"}}
test dict-24.13 {dict map command: script results} {
apply {{} {
dict map {k v} {a b} {
return ok,$k,$v
error "skipped return completely"
}
error "return didn't go far enough"
}}
} ok,a,b
test dict-24.14 {dict map command: handle representation loss} -setup {
set keys {}
set values {}
} -body {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[llength $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values]
} -cleanup {
unset dictVar keys values k v
} -result {4 {a c e g} {b d f h}}
test dict-24.14a {dict map command: handle representation loss} -body {
apply {{} {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[llength $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values]
}}
} -result {4 {a c e g} {b d f h}}
test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup {
unset -nocomplain accum
array set accum {}
} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict map {k v} $dictVar {
append accum($k) $v,
}
set result [lsort [array names accum]]
lappend result :
foreach k $result {
catch {lappend result $accum($k)}
}
return $result
} -cleanup {
unset dictVar k v result accum
} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
test dict-24.16 {dict map command in compilation context} {
apply {{} {
set res {x x x x x x}
dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
lset res $v $k
continue
}
return $res
}}
} {a b c d e f}
test dict-24.17 {dict map command in compilation context} {
# Bug 1379349 (dict for)
apply {{} {
set d [dict create a 1] ;# Dict must be unshared!
dict map {k v} $d {
dict set d $k 0 ;# Any modification will do
}
return $d
}}
} {a 0}
test dict-24.17a {dict map command in compilation context} {
# Bug 1379349 (dict for)
apply {{} {
set d [dict create a 1] ;# Dict must be unshared!
dict map {k v} $d {
dict set d $k 0 ;# Any modification will do
}
}}
} {a {a 0}}
test dict-24.18 {dict map command in compilation context} {
# Bug 1382528 (dict for)
apply {{} {
dict map {k v} {} {} ;# Note empty dict
catch { error foo } ;# Note compiled [catch]
}}
} 1
test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body {
di[list]ct map {k v} x {}
} -returnCodes 1 -result {missing value to go with key}
test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} {
apply {{x y args} {
dict map {a b} $x {}
concat "c=$y,$args"
}} {} 1 2 3
} {c=1,2 3}
proc linenumber {} {
dict get [info frame -1] line
}
test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} {
apply {{} {apply {n {
set e {}
set k {}
dict map {a b} {c {d {e {f g}}}} {
::tcl::dict::map {h i} $b {
dict update i e j {
::tcl::dict::update j f k {
return [expr {$n - [linenumber]}]
}
}
}
}
}} [linenumber]}}
} 5
test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug {
apply {{} {apply {n {
set e {}
set k {}
dict map {a {
b
}} {c {d {e {f g}}}} {
::tcl::dict::map {h {
i
}} ${
b
} {
dict update {
i
} e {
j
} {
::tcl::dict::update {
j
} f k {
return [expr {$n - [linenumber]}]
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.22 {dict map results (non-compiled)} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
return -level 0 "$k,$v"
}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.23 {dict map results (compiled)} {
apply {{} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
return -level 0 "$k,$v"
}
}}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.23a {dict map results (compiled)} {
apply {{list} {
dict map {k v} [dict map {k v} $list { list $v $k }] {
return -level 0 "$k,$v"
}
}} {a 1 b 2 c 3 d 4}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.24 {dict map with huge dict (non-compiled)} {
tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] {
expr { $k * $v }
}]
} 166666666600000
test dict-24.25 {dict map with huge dict (compiled)} {
apply {{n} {
tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] {
expr { $k * $v }
}]
}} 100000
} 166666666600000
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/dstring.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
testdstring free
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
testdstring free
|
| ︙ | ︙ |
Changes to library/msgcat/tests/encoding.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
package require tcltest 2
namespace eval ::tcl::test::encoding {
variable x
namespace import -force ::tcltest::*
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
variable x
lappend x "fromutf $args"
}
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
| > > > > > < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
package require tcltest 2
namespace eval ::tcl::test::encoding {
variable x
namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
}
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
variable x
lappend x "fromutf $args"
}
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
set old [encoding system]
} -constraints {testencoding} -body {
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
test encoding-24.1 {EscapeFreeProc on open channels} exec {
runInSubprocess {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
| | > | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
test encoding-24.1 {EscapeFreeProc on open channels} exec {
runInSubprocess {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab\u4e4e\u68d9g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}]
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
test encoding-27.1 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs ? ?
} -result {wrong # args: should be "encoding dirs ?dirList?"}
test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs "\{not a list"
} -result "expected directory list but got \"\{not a list\""
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/env.test.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
| | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
return [subst -novariables $s]
}
proc manglechar c {
return [format {\u%04x} [scan $c %c]]
}
set names [lsort [array names env]]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/event.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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::*
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 |
# file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
| > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
# file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
|
| ︙ | ︙ |
Changes to library/msgcat/tests/exec.test.
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
set sysenc [encoding system]
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
| | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
set sysenc [encoding system]
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u007f-\uffff\]" $s \
{[apply {c {format {\u%04x} [scan $c %c]}} &]} s
return [subst -novariables $s]
}
} -constraints {exec} -body {
# If this fails, it may give back: "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
# If it does, this means that the UTF -> external conversion did not occur
# before writing out the temp file.
|
| ︙ | ︙ |
Changes to library/msgcat/tests/execute.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
testConstraint testobj [expr {
| > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
testConstraint testobj [expr {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/expr-old.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
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
|
| ︙ | ︙ |
Changes to library/msgcat/tests/expr.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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.
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::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.
|
| ︙ | ︙ |
Changes to library/msgcat/tests/fCmd.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
# Don't know how to determine this constraint correctly
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
# Don't know how to determine this constraint correctly
|
| ︙ | ︙ |
Changes to library/msgcat/tests/fileName.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {[string index $tcl_platform(osVersion) 0] < 5 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {[string index $tcl_platform(osVersion) 0] < 5 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
| | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
} "/ foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
} {foo bar}
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
| | | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
} "/a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} "/a/b"
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join a b
} {a/b}
test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
file join [lindex [glob ~] 0]
} [file join $env(HOME)]
set oldpwd [pwd]
set oldhome $env(HOME)
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
file join [lindex [glob ~] 0]
} [file join $env(HOME)]
set oldpwd [pwd]
set oldhome $env(HOME)
catch {cd [makeDirectory tcl[pid]]}
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
touch globTest/x1.c
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 |
} -result ~/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
} -result ~/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
catch {removeDirectory tcl[pid]}
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/fileSystem.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
namespace import ::tcltest::*
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
cd [tcltest::temporaryDirectory]
| > > > > > > > > > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
namespace import ::tcltest::*
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
testConstraint loaddll 0
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::ddever [package require dde]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
set ::regver [package require registry]
set ::reglib [lindex [package ifneeded registry $::regver] 1]
testConstraint loaddll 1
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
cd [tcltest::temporaryDirectory]
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
set old [pwd]
} -constraints {win} -body {
set drv C:/
cd [lindex [glob -type d -dir $drv *] 0]
file norm [string range $drv 0 1]
} -cleanup {
cd $old
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
set old [pwd]
} -constraints {win} -body {
set drv C:/
cd [lindex [glob -type d -dir $drv *] 0]
file norm [string range $drv 0 1]
} -cleanup {
cd $old
} -match regexp -result {.*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
testPathEqual [file norm foo////bar] [file norm foo/bar]
} ok
test filesystem-1.41 {file normalisation with repeated separators} {win} {
testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]
} ok
test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
test filesystem-6.19 {empty file name} {file nativename ""} {}
test filesystem-6.20 {empty file name} {file normalize ""} {}
test filesystem-6.21 {empty file name} {file owned ""} 0
test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
| | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
test filesystem-6.19 {empty file name} {file nativename ""} {}
test filesystem-6.20 {empty file name} {file normalize ""} {}
test filesystem-6.21 {empty file name} {file owned ""} 0
test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
} -result {could not read link "": no such file or directory}
test filesystem-6.25 {empty file name} -returnCodes error -body {
file rename "" ""
} -result {error renaming "": no such file or directory}
test filesystem-6.26 {empty file name} {file rootname ""} {}
test filesystem-6.27 {empty file name} -returnCodes error -body {
file separator ""
} -result {unrecognised path}
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
| | | < | | | < | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::ddelib]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
load simplefs:/[file tail $::ddelib] dde
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads reg via a complex copy-to-temp operation
load simplefs:/[file tail $::reglib] Registry
unload simplefs:/[file tail $::reglib]
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/foreach.test.
| ︙ | ︙ | |||
261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
# cleanup
catch {unset a}
catch {unset x}
catch {rename foo {}}
::tcltest::cleanupTests
return
| > > > > > > > > > | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
test foreach-11.1 {error then dereference loop var (dev bug)} {
catch { foreach a 0 b {1 2 3} { error x } }
set a
} 0
test foreach-11.2 {error then dereference loop var (dev bug)} {
catch { foreach a 0 b {1 2 3} { incr a $b; error x } }
set a
} 1
# cleanup
catch {unset a}
catch {unset x}
catch {rename foo {}}
::tcltest::cleanupTests
return
|
Changes to library/msgcat/tests/format.test.
| ︙ | ︙ | |||
545 546 547 548 549 550 551 |
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
| < | < < | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
format %llx 0
} 0
test format-19.3 {Bug 2830354} {
string length [format %340f 0]
} 340
# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
set x [dict create a b c d]
format %s $x
# After this, obj in $x should be a dict with a non-NULL bytes field
tcl::unsupported::representation $x
} -match glob -result {value is a dict with *, string representation "*"}
# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/get.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/http.test.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
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}
puts "Running httpd in thread $httpthread"
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
| > | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
} -match regexp -result {(?n)Accept \*/\*
Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
| > > > > > > > > > > > > > > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
} -match regexp -result {(?n)Accept \*/\*
Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
test http-3.29 "http::geturl $ipv6url" -body {
# We only want to see if the URL gets parsed correctly. This is
# the case if http::geturl succeeds or returns a socket related
# error. If the parsing is wrong, we'll get a parse error.
# It'd be better to separate the URL parser from http::geturl, so
# that it can be tested without also trying to make a connection.
set error [catch {http::geturl $ipv6url -validate 1} token]
if {$error && [string match "couldn't open socket: *" $token]} {
set error 0
}
set error
} -cleanup {
catch { http::cleanup $token }
} -result 0
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/indexObj.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/info.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
| > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
| < | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
test info-7.1 {info exists option} -body {
set value foo
info exists value
} -cleanup {unset value} -result 1
test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body {
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
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}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
proc reduce {frame} {
| > > | < < > | < | < < | | | > > < < | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
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}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
proc reduce {frame} {
set cmd [dict get $frame cmd]
if {[regexp \n $cmd]} {
dict set frame cmd \
[string range [lindex [split $cmd \n] 0] 0 end-4]
}
if {[dict exists $frame file]} {
dict set frame file \
[file tail [dict get $frame file]]
}
return $frame
}
proc subinterp {} { interp create sub ; interp debug sub -frame 1;
interp eval sub [list proc reduce [info args reduce] [info body reduce]]
}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
lappend res [list $level [reduce [info frame $level]]]
incr level -1
}
return $res
}
test info-22.0 {info frame, levels} {!singleTestInterp} {
info frame
} 7
test info-22.1 {info frame, bad level relative} {!singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame -8} msg
set msg
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
reduce [info frame 1]
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
| | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
reduce [info frame 1]
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
test info-23.0.0 {eval'd info frame} {!singleTestInterp} {
eval {info frame}
} 8
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
set script {info frame 0}
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
| | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
set script {info frame 0}
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
| | | 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 |
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c}
# -------------------------------------------------------------------------
# 6 cases.
## DV. direct-var - unchanged
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
| | | | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 |
test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
set script {
set y DPV
etrace
}
join [lrange [control y $script] 0 3] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}
# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# literal sharing
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
} -cleanup {
rename abra {}
} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
| | | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
} -cleanup {
rename abra {}
} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
[info frame 0];# line 1457
}
return [reduce $xxx::res]
} {type source line 1457 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {
namespace eval xxx variable res \
[list [reduce [info frame 0]]];# line 1464
return $xxx::res
} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
set y DL.
etrace
}] 0 2] \n
}
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
| > > > > > > | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 |
set y DL.
etrace
}] 0 2] \n
}
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# This test at the end of this file _only_ to avoid disturbing above line
# numbers. It _belongs_ after info-9.12
test info-9.13 {info level option, value in global context} -body {
uplevel #0 {info level 2}
} -returnCodes error -result {bad level "2"}
# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
|
Changes to library/msgcat/tests/interp.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# 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 testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source 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}
foreach i [interp slaves] {
interp delete $i
}
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
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: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}
foreach i [interp slaves] {
interp delete $i
}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/io.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
# 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}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
| > > > > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
# 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}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
| ︙ | ︙ |
Changes to library/msgcat/tests/ioCmd.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
| > > > | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/ioTrans.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
| > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# testchannel cut|splice Both needed to test the reflection in threads.
# thread::send
#----------------------------------------------------------------------
# ### ### ### ######### ######### #########
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
lappend res [set c [chan push [tempchan] foo]]
rename foo {}
lappend res [file channels file*]
lappend res [file channels rt*]
lappend res [catch {close $c} msg] $msg
lappend res [file channels file*]
lappend res [file channels rt*]
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return
}
lappend res [set c [chan push [tempchan] foo]]
close $c
# Close deleted the channel.
lappend res [file channels rt*]
# Channel destruction does not kill handler command!
lappend res [info command foo]
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code error 5
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
# Channel is gone despite error.
lappend res [file channels rt*]
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
error FOO
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg $::errorInfo
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return SOMETHING
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 3
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 4
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
set res {}
} -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -level 5 -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg opt] $msg
noteOpts $opt
} -match glob -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
| > > > > > > > > > > | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
lappend res [set c [chan push [tempchan] foo]]
rename foo {}
lappend res [file channels file*]
lappend res [file channels rt*]
lappend res [catch {close $c} msg] $msg
lappend res [file channels file*]
lappend res [file channels rt*]
} -cleanup {
tempdone
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return
}
lappend res [set c [chan push [tempchan] foo]]
close $c
# Close deleted the channel.
lappend res [file channels rt*]
# Channel destruction does not kill handler command!
lappend res [info command foo]
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code error 5
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
# Channel is gone despite error.
lappend res [file channels rt*]
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
error FOO
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg $::errorInfo
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return SOMETHING
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 3
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 4
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
set res {}
} -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -level 5 -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg opt] $msg
noteOpts $opt
} -match glob -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
# ### ### ### ######### ######### #########
| > > | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -cleanup {
tempdone
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
# ### ### ### ######### ######### #########
|
| ︙ | ︙ |
Changes to library/msgcat/tests/iogt.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
| > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/lindex.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
list [catch {testevalex lindex} result] $result
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
list [catch {testevalex lindex} result] $result
|
| ︙ | ︙ |
Changes to library/msgcat/tests/link.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/listObj.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
} {}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
} {}
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
test listobj-11.1 {bug 3598580} {
testobj bug3598580
} 123
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/load.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
| | | | | > > > > > > | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
test load-1.2 {basic errors} {} {
list [catch {load a b c d} msg] $msg
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
test load-1.3 {basic errors} {} {
list [catch {load a b foobar} msg] $msg
} {1 {could not find interpreter "foobar"}}
test load-1.4 {basic errors} {} {
list [catch {load -global {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.5 {basic errors} {} {
list [catch {load -lazy {} {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.6 {basic errors} {} {
list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}
test load-1.7 {basic errors} {} {
list [catch {load -abc foo} msg] $msg
} "1 {bad option \"-abc\": must be -global, -lazy, or --}"
test load-1.8 {basic errors} {} {
list [catch {load -global} msg] $msg
} "1 {couldn't figure out package name for -global}"
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
load -global [file join $testDir pkga$ext]
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load -lazy [file join $testDir pkgb$ext] pKgB child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
| | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
load -global [file join $testDir pkga$ext] pkga
load {} pkga x
set result [info loaded x]
interp delete x
set result
} [list [list [file join $testDir pkga$ext] Pkga]]
# On some platforms, like SunOS 4.1.3, these tests can't be run because
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
| | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}]
interp delete child
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
-constraints {teststaticpkg} \
-setup {
interp create child1
interp create child2
load {} Tcltest child1
load {} Tcltest child2
} \
-body {
child1 eval { teststaticpkg Loadninepointone 0 1 }
child2 eval { teststaticpkg Loadninepointone 0 1 }
list \
[child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} \
-match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \
-cleanup { interp delete child1 ; interp delete child2 }
test load-10.1 {load from vfs} \
-constraints [list $dll $loaded testsimplefilesystem] \
-setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \
-body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
-result {0 {}} \
|
| ︙ | ︙ |
Changes to library/msgcat/tests/lrange.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# 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::*
}
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# 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::*
}
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
test lrange-1.3 {range of list elements} {
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
# emacs highlighting bug workaround --> "
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-3.1 {Bug 3588366: end-offsets before start} {
apply {l {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/lset.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
set noRead {}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
set noRead {}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/misc.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
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])
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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]]
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])
|
| ︙ | ︙ |
Changes to library/msgcat/tests/msgcat.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
| | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
if {[catch {package require msgcat 1.5.0}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test."
return
}
namespace eval ::msgcat::test {
namespace import ::msgcat::*
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
|
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
| > > > > > > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
if {([info sharedlibextension] == ".dll")
&& ![catch {package require registry}]} {
# Windows and Cygwin have other ways to determine the
# locale when the environment variables are missing
# and the registry package is present
continue
}
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 613 614 615 616 617 618 |
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
cleanupTests
}
namespace delete ::msgcat::test
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
# Tests msgcat-8.*: [mcflset]
set msgdir1 [makeDirectory msgdir1]
makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1
test msgcat-8.1 {mcflset} -setup {
variable locale [mclocale]
mclocale l1
mcload $msgdir1
} -cleanup {
mclocale $locale
} -body {
mc k1
} -result v1
removeFile l1.msg $msgdir1
removeDirectory msgdir1
set msgdir2 [makeDirectory msgdir2]
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3
# chained mcload
test msgcat-8.2 {mcflset} -setup {
variable locale [mclocale]
mclocale l2
mcload $msgdir2
} -cleanup {
mclocale $locale
} -body {
return [mc k2][mc k3]
} -result v2v3
removeFile l2.msg $msgdir2
removeDirectory msgdir2
removeDirectory msgdir3
cleanupTests
}
namespace delete ::msgcat::test
return
|
Changes to library/msgcat/tests/namespace.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# 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::*
testConstraint memory [llength [info commands memory]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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::*
testConstraint memory [llength [info commands memory]]
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/notify.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
|
| ︙ | ︙ |
Changes to library/msgcat/tests/nre.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
| < < | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-1.2 {self-recursive lambdas} -setup {
set a [list i [makebody {apply $::a $i}]]
} -body {
setabs
apply $a 0
} -cleanup {
unset a
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-1.3 {mutually recursive procs and lambdas} -setup {
proc a i {
apply $::b [incr i]
}
set b [list i [makebody {a $i}]]
} -body {
setabs
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
::foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
| | < | < | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
::foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
} -result {{0 2 2 2} 0}
test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
}
proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
} -body {
foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
} -result {{0 2 2 2} 0}
test nre-6.1 {[uplevel] is not recursive} -setup {
proc a i [makebody {uplevel 1 [list a $i]}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-6.2 {[uplevel] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
} -body {
a 0
} -cleanup {
rename a {}
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
| < < < < < < < < < < < < < < < < < < | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
test nre-7.2 {[if] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.3 {[while] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.4 {[for] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.5 {[foreach] is not recursive} -setup {
#
# Enable once [foreach] is NR-enabled
#
setabs
proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
test nre-7.6 {[eval] is not recursive} -setup {
proc a i [makebody {eval [list a $i]}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
test nre-7.7 {[eval] is not recursive} -setup {
proc a i [makebody {eval "a $i"}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
proc foo args {}
foo
coroutine bar apply {{} {
yield
proc foo args {return ok}
while 1 {
yield [incr i]
foo
}
}}
} -body {
# if switching to plain eval is not nre aware, this will cause a "cannot
# yield" error
list [bar] [bar] [bar]
} -cleanup {
rename bar {}
rename foo {}
} -result {1 2 3}
test nre-8.1 {nre and {*}} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the TEBCdataPtr. This crashes on failure.
proc inner {} {
set long [lrepeat 1000000 1]
list {*}$long
}
proc outer {} inner
lrange [outer] 0 2
} -cleanup {
rename inner {}
rename outer {}
} -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
# done properly.
proc nop {} {}
proc crash {} {
foreach val [list {*}[lrepeat 100000 x]] {
nop
}
}
crash
} -cleanup {
rename nop {}
rename crash {}
}
#
# Basic TclOO tests
#
test nre-oo.1 {really deep calls in oo - direct} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {foo bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {[self] bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.3 {really deep calls in oo - private calls} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {my bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.4 {really deep calls in oo - overriding} -setup {
oo::class create foo {
method bar i [makebody {my bar $i}]
}
oo::class create boo {
superclass foo
method bar i [makebody {next $i}]
}
} -body {
setabs
[boo new] bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.5 {really deep calls in oo - forwards} -setup {
oo::object create foo
set body [makebody {my boo $i}]
oo::objdefine foo "
method bar i {$body}
forward boo ::foo bar
"
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 2 1 1} 0}
#
# NASTY BUG found by tcllib's interp package
#
test nre-X.1 {eval in wrong interp} -setup {
set i [interp create]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/obj.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/oo.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2012 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/ooNext2.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | < < | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/parse.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
| > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
cleanupTests
}
namespace delete ::tcl::test::parse
return
| > > > > > > > > | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
test parse-21.0 {Bug 1884496} testevent {
set ::script {set a [p]; return -level 0 $a}
proc ::p {} {string first s $::script}
testevent queue a head $::script
update
} {}
cleanupTests
}
namespace delete ::tcl::test::parse
return
|
Changes to library/msgcat/tests/parseExpr.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/parseOld.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# 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]]
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
|
| ︙ | ︙ |
Changes to library/msgcat/tests/platform.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/reg.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
|
| ︙ | ︙ |
Changes to library/msgcat/tests/registry.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
| | < < < | | > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::regver [package require registry 1.3.0]
}]} {
testConstraint reg 1
}
}
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
} {1.3.0}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
| | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} [string repeat x 16383]
test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/rename.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/resolver.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
|
| ︙ | ︙ |
Changes to library/msgcat/tests/result.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/set.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
|
| ︙ | ︙ |
Changes to library/msgcat/tests/socket.test.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | # 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::* # Some tests require the Thread package or exec command | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
# 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::*
# 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]]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
proc randport {} { expr {int(rand()*16383+49152)} }
# Test the latency of tcp connections over the loopback interface. Some OSes
|
| ︙ | ︙ |
Changes to library/msgcat/tests/string.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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 testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 |
test string-18.10 {string trim} {
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} {
| | | | | | | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 |
test string-18.10 {string trim} {
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
} ABC\u1361
test string-19.1 {string trimleft} {
list [catch {string trimleft} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
test string-19.2 {string trimleft} {
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
} \u1361ABC
test string-20.1 {string trimright errors} {
list [catch {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, 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 "
} { XYZ}
test string-20.4 {string trimright} {
string trimright " "
} {}
test string-20.5 {string trimright} {
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
} ABC\u1361
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"}}
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 |
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 {
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 {
tcl::prefix match -error str1 str2
| | | | 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 |
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 {
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 {
tcl::prefix match -error str1 str2
} -returnCodes 1 -result {missing value for -error}
test string-26.4 {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
} -returnCodes 1 -result {missing value for -message}
test string-26.5 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
test string-26.6 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/stringComp.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
| > > > | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# 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] != {}}]
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, 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
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
[string match *a*l*\u0000*cba* $longString] \
[string match *===* $longString]
}
foo
} {0 1 1 1 0 0}
## string range
| > > > > | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
[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
## not yet bc
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 | ## not yet bc ## string trim* ## not yet bc ## string word* ## not yet bc | | > > > > | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
## not yet bc
## string trim*
## not yet bc
## string word*
## not yet bc
# cleanup
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgcat/tests/stringObj.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/tailcall.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ |
Changes to library/msgcat/tests/thread.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
# Some tests require the Thread package
| > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
# Some tests require the Thread package
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# Some tests may not work under valgrind
testConstraint notValgrind [expr {![testConstraint valgrind]}]
set threadSuperKillScript {
rename catch ""
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
while {[set x [testthread event]]} {
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
while {[set x [testthread event]]} {
#puts "WARNING: drained $x event(s) on main thread"
}
}
testthread errorproc ThreadError
set mainThread [testthread id]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/trace.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc getbytes {} {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc getbytes {} {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/unixFCmd.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/unixFile.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
|
| ︙ | ︙ |
Changes to library/msgcat/tests/unixNotfy.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
| | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# 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
|
| ︙ | ︙ |
Changes to library/msgcat/tests/unload.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
|
| ︙ | ︙ |
Changes to library/msgcat/tests/upvar.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/utf.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
|
| ︙ | ︙ |
Changes to library/msgcat/tests/util.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
# Big test for correct ordering of data in [expr]
| > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# 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]]
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/var.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
| > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/winDde.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
| > > > | < < < | > | < | < < > < | < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::ddever [package require dde 1.4.0]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
}
# -------------------------------------------------------------------------
# Setup a script for a test server
#
set scriptName [makeFile {} script1.tcl]
proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
| > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
} {1.4.0}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1 ""
dde execute -async TclEval self [list set \xe1 foo]
update
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
| | | | | | | | | | | | | > > > > > > > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1 ""
dde execute -async TclEval self [list set \xe1 foo]
update
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request TclEval self \xe1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
set \xe1 ""
dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf8} -constraints dde -body {
set \xe1 "not set"
dde execute TclEval self "set \xe1 \xc4"
scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints dde -body {
set \xe1 "not set"
dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
scan [set \xe1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke TclEval self \xe1 \xc4
dde request TclEval self \xe1
} -result \xc4
test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke -binary TclEval self \xe1 \xc3\x84\x00
dde request TclEval self \xe1
} -result \xc4
# -------------------------------------------------------------------------
test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.1
set child [createChildProcess $name]
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
| | | | | | | | > > > > > > > > > > | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
dde execute TclEval $name [list set \xe1 foo]
set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
set \xe1 [dde eval $name set \xe1 foo]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
set \xe1 ""
set name ch\xEDld-4.5
set child [createChildProcess $name]
dde poke TclEval $name \xe1 foo
set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
# -------------------------------------------------------------------------
test winDde-5.1 {check for bad arguments} -constraints dde -body {
dde execute "" "" "" ""
} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
test winDde-5.2 {check for bad arguments} -constraints dde -body {
|
| ︙ | ︙ |
Changes to library/msgcat/tests/winFCmd.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/winFile.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace import -force ::tcltest::*
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
testConstraint win2000 0
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
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"}]
}
|
| ︙ | ︙ |
Changes to library/msgcat/tests/winNotify.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
after 1000 { set done 1 }
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
after 1000 { set done 1 }
|
| ︙ | ︙ |
Changes to library/msgcat/tests/winPipe.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
| > > > > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
testConstraint testexcept [llength [info commands testexcept]]
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
| | > | > | > | > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}
set path(nothing) [makeFile {} nothing]
close [open $path(nothing) w]
|
| ︙ | ︙ |
Changes to library/msgcat/tests/winTime.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
|
| ︙ | ︙ |
Changes to library/msgcat/tests/zlib.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # 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. | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
# 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 zlib [llength [info commands zlib]]
test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
zlib
} -result {wrong # args: should be "zlib command arg ?...?"}
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
test zlib-1.3 {zlib basics} -constraints zlib -body {
zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
package present zlib
} -result 2.0
test zlib-2.1 {zlib compress/decompress} zlib {
zlib decompress [zlib compress abcdefghijklm]
} abcdefghijklm
test zlib-3.1 {zlib deflate/inflate} zlib {
zlib inflate [zlib deflate abcdefghijklm]
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
set s [zlib stream compress]
} -body {
$s ?
} -cleanup {
$s close
| | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
set s [zlib stream compress]
} -body {
$s ?
} -cleanup {
$s close
} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset}
test zlib-7.1 {zlib stream} zlib {
set s [zlib stream compress]
$s put -finalize abcdeEDCBA
set data [$s get]
set result [list [$s get] [format %x [$s checksum]]]
$s close
lappend result [zlib decompress $data]
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
after 250 {lappend ::res MIDDLE}
vwait ::done
set ::res
} -cleanup {
catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
set file [makeFile {} test.gz]
set f [open $sfile wb]
puts -nonewline $f [zlib gzip [string repeat a 81920]]
close $f
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
after 250 {lappend ::res MIDDLE}
vwait ::done
set ::res
} -cleanup {
catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-8.6 {transformation and fconfigure} -setup {
set file [makeFile {} test.z]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
test zlib-8.7 {transformation and fconfigure} -setup {
set file [makeFile {} test.gz]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
# Input is headers from fetching SPDY draft
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
test zlib-8.8 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib decompress $compressed} err opt
list [string length [zlib compress $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode] [zlib adler32 $spdyDict]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
test zlib-8.9 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
set result [fconfigure $outSide -checksum]
chan pop $outSide
$strm put -dictionary $spdyDict [read $inSide]
lappend result [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {3064818174 358 358}
test zlib-8.10 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib inflate $compressed} err opt
list [string length [zlib deflate $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {254 212 {data error} {TCL ZLIB DATA}}
test zlib-8.11 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream inflate]
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
$strm put -dictionary $spdyDict [read $inSide]
list [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.12 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide
fconfigure $outSide -blocking 0 -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]] \
[fconfigure $inSide -checksum]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.13 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]] \
[fconfigure $inSide -checksum]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.14 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide
fconfigure $outSide -blocking 0 -buffering none -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.15 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -buffering none -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
set file [makeFile {} test.gz]
set f [open $sfile wb]
puts -nonewline $f [zlib gzip [string repeat a 81920]]
close $f
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
close $f
set d [zlib gunzip $d -header h]
list [regexp -all "hello" $d] [dict get $h filename] \
[string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 /foo/bar 0}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
close $f
set d [zlib gunzip $d -header h]
list [regexp -all "hello" $d] [dict get $h filename] \
[string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 /foo/bar 0}
test zlib-11.3 {Bug 3595576 variant} -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \
[string repeat "hello" 1000]
close $f
set f [open $file rb]
set d [read $f]
close $f
zlib gunzip $d -header noSuchNs::foo
} -cleanup {
removeFile $file
} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to library/msgs/uk.msg.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
"\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"\
| | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
"\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"\
|
| ︙ | ︙ |
Changes to library/reg/pkgIndex.tcl.
|
| | | | 1 2 3 4 5 6 7 8 9 |
if {([info commands ::tcl::pkgconfig] eq "")
|| ([info sharedlibextension] ne ".dll")} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded registry 1.3.0 \
[list load [file join $dir tclreg13g.dll] registry]
} else {
package ifneeded registry 1.3.0 \
[list load [file join $dir tclreg13.dll] registry]
}
|
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
package require Tcl 8.5 ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
package require Tcl 8.5 ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.3.5
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return -code error "missing value for option $option"
}
}
proc configure args {
| > | > | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return -code error "missing value for option $option"
}
}
proc configure args {
if {[llength $args] > 1} {
RemoveAutoConfigureTraces
}
set code [catch {Configure {*}$args} msg]
return -code $code $msg
}
proc AcceptVerbose { level } {
set level [AcceptList $level]
if {[llength $level] == 1} {
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Casablanca.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
{1243814400 3600 1 WEST}
{1250809200 0 0 WET}
{1272758400 3600 1 WEST}
{1281222000 0 0 WET}
{1301788800 3600 1 WEST}
{1312066800 0 0 WET}
{1335664800 3600 1 WEST}
{1348970400 0 0 WET}
{1367114400 3600 1 WEST}
{1380420000 0 0 WET}
{1398564000 3600 1 WEST}
{1411869600 0 0 WET}
{1430013600 3600 1 WEST}
{1443319200 0 0 WET}
| > > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
{1243814400 3600 1 WEST}
{1250809200 0 0 WET}
{1272758400 3600 1 WEST}
{1281222000 0 0 WET}
{1301788800 3600 1 WEST}
{1312066800 0 0 WET}
{1335664800 3600 1 WEST}
{1342749600 0 0 WET}
{1345428000 3600 1 WEST}
{1348970400 0 0 WET}
{1367114400 3600 1 WEST}
{1380420000 0 0 WET}
{1398564000 3600 1 WEST}
{1411869600 0 0 WET}
{1430013600 3600 1 WEST}
{1443319200 0 0 WET}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Araguaina.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 57 |
{970974000 -7200 1 BRST}
{982461600 -10800 0 BRT}
{1003028400 -7200 1 BRST}
{1013911200 -10800 0 BRT}
{1036292400 -7200 1 BRST}
{1045360800 -10800 0 BRT}
{1064368800 -10800 0 BRT}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
{970974000 -7200 1 BRST}
{982461600 -10800 0 BRT}
{1003028400 -7200 1 BRST}
{1013911200 -10800 0 BRT}
{1036292400 -7200 1 BRST}
{1045360800 -10800 0 BRT}
{1064368800 -10800 0 BRT}
{1350788400 -7200 0 BRST}
{1361066400 -10800 0 BRT}
{1382238000 -7200 1 BRST}
{1392516000 -10800 0 BRT}
{1413687600 -7200 1 BRST}
{1424570400 -10800 0 BRT}
{1445137200 -7200 1 BRST}
{1456020000 -10800 0 BRT}
{1476586800 -7200 1 BRST}
{1487469600 -10800 0 BRT}
{1508036400 -7200 1 BRST}
{1518919200 -10800 0 BRT}
{1540090800 -7200 1 BRST}
{1550368800 -10800 0 BRT}
{1571540400 -7200 1 BRST}
{1581818400 -10800 0 BRT}
{1602990000 -7200 1 BRST}
{1613872800 -10800 0 BRT}
{1634439600 -7200 1 BRST}
{1645322400 -10800 0 BRT}
{1665889200 -7200 1 BRST}
{1677376800 -10800 0 BRT}
{1697338800 -7200 1 BRST}
{1708221600 -10800 0 BRT}
{1729393200 -7200 1 BRST}
{1739671200 -10800 0 BRT}
{1760842800 -7200 1 BRST}
{1771725600 -10800 0 BRT}
{1792292400 -7200 1 BRST}
{1803175200 -10800 0 BRT}
{1823742000 -7200 1 BRST}
{1834624800 -10800 0 BRT}
{1855191600 -7200 1 BRST}
{1866074400 -10800 0 BRT}
{1887246000 -7200 1 BRST}
{1897524000 -10800 0 BRT}
{1918695600 -7200 1 BRST}
{1928973600 -10800 0 BRT}
{1950145200 -7200 1 BRST}
{1960423200 -10800 0 BRT}
{1981594800 -7200 1 BRST}
{1992477600 -10800 0 BRT}
{2013044400 -7200 1 BRST}
{2024532000 -10800 0 BRT}
{2044494000 -7200 1 BRST}
{2055376800 -10800 0 BRT}
{2076548400 -7200 1 BRST}
{2086826400 -10800 0 BRT}
{2107998000 -7200 1 BRST}
{2118880800 -10800 0 BRT}
{2139447600 -7200 1 BRST}
{2150330400 -10800 0 BRT}
{2170897200 -7200 1 BRST}
{2181780000 -10800 0 BRT}
{2202346800 -7200 1 BRST}
{2213229600 -10800 0 BRT}
{2234401200 -7200 1 BRST}
{2244679200 -10800 0 BRT}
{2265850800 -7200 1 BRST}
{2276128800 -10800 0 BRT}
{2297300400 -7200 1 BRST}
{2307578400 -10800 0 BRT}
{2328750000 -7200 1 BRST}
{2339632800 -10800 0 BRT}
{2360199600 -7200 1 BRST}
{2371082400 -10800 0 BRT}
{2391649200 -7200 1 BRST}
{2402532000 -10800 0 BRT}
{2423703600 -7200 1 BRST}
{2433981600 -10800 0 BRT}
{2455153200 -7200 1 BRST}
{2465431200 -10800 0 BRT}
{2486602800 -7200 1 BRST}
{2497485600 -10800 0 BRT}
{2518052400 -7200 1 BRST}
{2528935200 -10800 0 BRT}
{2549502000 -7200 1 BRST}
{2560384800 -10800 0 BRT}
{2580951600 -7200 1 BRST}
{2591834400 -10800 0 BRT}
{2613006000 -7200 1 BRST}
{2623284000 -10800 0 BRT}
{2644455600 -7200 1 BRST}
{2654733600 -10800 0 BRT}
{2675905200 -7200 1 BRST}
{2686788000 -10800 0 BRT}
{2707354800 -7200 1 BRST}
{2718237600 -10800 0 BRT}
{2738804400 -7200 1 BRST}
{2749687200 -10800 0 BRT}
{2770858800 -7200 1 BRST}
{2781136800 -10800 0 BRT}
{2802308400 -7200 1 BRST}
{2812586400 -10800 0 BRT}
{2833758000 -7200 1 BRST}
{2844036000 -10800 0 BRT}
{2865207600 -7200 1 BRST}
{2876090400 -10800 0 BRT}
{2896657200 -7200 1 BRST}
{2907540000 -10800 0 BRT}
{2928106800 -7200 1 BRST}
{2938989600 -10800 0 BRT}
{2960161200 -7200 1 BRST}
{2970439200 -10800 0 BRT}
{2991610800 -7200 1 BRST}
{3001888800 -10800 0 BRT}
{3023060400 -7200 1 BRST}
{3033943200 -10800 0 BRT}
{3054510000 -7200 1 BRST}
{3065392800 -10800 0 BRT}
{3085959600 -7200 1 BRST}
{3096842400 -10800 0 BRT}
{3118014000 -7200 1 BRST}
{3128292000 -10800 0 BRT}
{3149463600 -7200 1 BRST}
{3159741600 -10800 0 BRT}
{3180913200 -7200 1 BRST}
{3191191200 -10800 0 BRT}
{3212362800 -7200 1 BRST}
{3223245600 -10800 0 BRT}
{3243812400 -7200 1 BRST}
{3254695200 -10800 0 BRT}
{3275262000 -7200 1 BRST}
{3286144800 -10800 0 BRT}
{3307316400 -7200 1 BRST}
{3317594400 -10800 0 BRT}
{3338766000 -7200 1 BRST}
{3349044000 -10800 0 BRT}
{3370215600 -7200 1 BRST}
{3381098400 -10800 0 BRT}
{3401665200 -7200 1 BRST}
{3412548000 -10800 0 BRT}
{3433114800 -7200 1 BRST}
{3443997600 -10800 0 BRT}
{3464564400 -7200 1 BRST}
{3475447200 -10800 0 BRT}
{3496618800 -7200 1 BRST}
{3506896800 -10800 0 BRT}
{3528068400 -7200 1 BRST}
{3538346400 -10800 0 BRT}
{3559518000 -7200 1 BRST}
{3570400800 -10800 0 BRT}
{3590967600 -7200 1 BRST}
{3601850400 -10800 0 BRT}
{3622417200 -7200 1 BRST}
{3633300000 -10800 0 BRT}
{3654471600 -7200 1 BRST}
{3664749600 -10800 0 BRT}
{3685921200 -7200 1 BRST}
{3696199200 -10800 0 BRT}
{3717370800 -7200 1 BRST}
{3727648800 -10800 0 BRT}
{3748820400 -7200 1 BRST}
{3759703200 -10800 0 BRT}
{3780270000 -7200 1 BRST}
{3791152800 -10800 0 BRT}
{3811719600 -7200 1 BRST}
{3822602400 -10800 0 BRT}
{3843774000 -7200 1 BRST}
{3854052000 -10800 0 BRT}
{3875223600 -7200 1 BRST}
{3885501600 -10800 0 BRT}
{3906673200 -7200 1 BRST}
{3917556000 -10800 0 BRT}
{3938122800 -7200 1 BRST}
{3949005600 -10800 0 BRT}
{3969572400 -7200 1 BRST}
{3980455200 -10800 0 BRT}
{4001626800 -7200 1 BRST}
{4011904800 -10800 0 BRT}
{4033076400 -7200 1 BRST}
{4043354400 -10800 0 BRT}
{4064526000 -7200 1 BRST}
{4074804000 -10800 0 BRT}
{4095975600 -7200 1 BRST}
}
|
Changes to library/tzdata/America/Bahia.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
{1003028400 -7200 1 BRST}
{1013911200 -10800 0 BRT}
{1036292400 -7200 1 BRST}
{1045360800 -10800 0 BRT}
{1064368800 -10800 0 BRT}
{1318734000 -7200 0 BRST}
{1330221600 -10800 0 BRT}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 60 61 62 63 64 65 66 67 68 |
{1003028400 -7200 1 BRST}
{1013911200 -10800 0 BRT}
{1036292400 -7200 1 BRST}
{1045360800 -10800 0 BRT}
{1064368800 -10800 0 BRT}
{1318734000 -7200 0 BRST}
{1330221600 -10800 0 BRT}
{1350784800 -10800 0 BRT}
}
|
Changes to library/tzdata/America/Havana.
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
{1236488400 -14400 1 CDT}
{1256446800 -18000 0 CST}
{1268542800 -14400 1 CDT}
{1288501200 -18000 0 CST}
{1300597200 -14400 1 CDT}
{1321160400 -18000 0 CST}
{1333256400 -14400 1 CDT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
{1236488400 -14400 1 CDT}
{1256446800 -18000 0 CST}
{1268542800 -14400 1 CDT}
{1288501200 -18000 0 CST}
{1300597200 -14400 1 CDT}
{1321160400 -18000 0 CST}
{1333256400 -14400 1 CDT}
{1352005200 -18000 0 CST}
{1362891600 -14400 1 CDT}
{1383454800 -18000 0 CST}
{1394341200 -14400 1 CDT}
{1414904400 -18000 0 CST}
{1425790800 -14400 1 CDT}
{1446354000 -18000 0 CST}
{1457845200 -14400 1 CDT}
{1478408400 -18000 0 CST}
{1489294800 -14400 1 CDT}
{1509858000 -18000 0 CST}
{1520744400 -14400 1 CDT}
{1541307600 -18000 0 CST}
{1552194000 -14400 1 CDT}
{1572757200 -18000 0 CST}
{1583643600 -14400 1 CDT}
{1604206800 -18000 0 CST}
{1615698000 -14400 1 CDT}
{1636261200 -18000 0 CST}
{1647147600 -14400 1 CDT}
{1667710800 -18000 0 CST}
{1678597200 -14400 1 CDT}
{1699160400 -18000 0 CST}
{1710046800 -14400 1 CDT}
{1730610000 -18000 0 CST}
{1741496400 -14400 1 CDT}
{1762059600 -18000 0 CST}
{1772946000 -14400 1 CDT}
{1793509200 -18000 0 CST}
{1805000400 -14400 1 CDT}
{1825563600 -18000 0 CST}
{1836450000 -14400 1 CDT}
{1857013200 -18000 0 CST}
{1867899600 -14400 1 CDT}
{1888462800 -18000 0 CST}
{1899349200 -14400 1 CDT}
{1919912400 -18000 0 CST}
{1930798800 -14400 1 CDT}
{1951362000 -18000 0 CST}
{1962853200 -14400 1 CDT}
{1983416400 -18000 0 CST}
{1994302800 -14400 1 CDT}
{2014866000 -18000 0 CST}
{2025752400 -14400 1 CDT}
{2046315600 -18000 0 CST}
{2057202000 -14400 1 CDT}
{2077765200 -18000 0 CST}
{2088651600 -14400 1 CDT}
{2109214800 -18000 0 CST}
{2120101200 -14400 1 CDT}
{2140664400 -18000 0 CST}
{2152155600 -14400 1 CDT}
{2172718800 -18000 0 CST}
{2183605200 -14400 1 CDT}
{2204168400 -18000 0 CST}
{2215054800 -14400 1 CDT}
{2235618000 -18000 0 CST}
{2246504400 -14400 1 CDT}
{2267067600 -18000 0 CST}
{2277954000 -14400 1 CDT}
{2298517200 -18000 0 CST}
{2309403600 -14400 1 CDT}
{2329966800 -18000 0 CST}
{2341458000 -14400 1 CDT}
{2362021200 -18000 0 CST}
{2372907600 -14400 1 CDT}
{2393470800 -18000 0 CST}
{2404357200 -14400 1 CDT}
{2424920400 -18000 0 CST}
{2435806800 -14400 1 CDT}
{2456370000 -18000 0 CST}
{2467256400 -14400 1 CDT}
{2487819600 -18000 0 CST}
{2499310800 -14400 1 CDT}
{2519874000 -18000 0 CST}
{2530760400 -14400 1 CDT}
{2551323600 -18000 0 CST}
{2562210000 -14400 1 CDT}
{2582773200 -18000 0 CST}
{2593659600 -14400 1 CDT}
{2614222800 -18000 0 CST}
{2625109200 -14400 1 CDT}
{2645672400 -18000 0 CST}
{2656558800 -14400 1 CDT}
{2677122000 -18000 0 CST}
{2688613200 -14400 1 CDT}
{2709176400 -18000 0 CST}
{2720062800 -14400 1 CDT}
{2740626000 -18000 0 CST}
{2751512400 -14400 1 CDT}
{2772075600 -18000 0 CST}
{2782962000 -14400 1 CDT}
{2803525200 -18000 0 CST}
{2814411600 -14400 1 CDT}
{2834974800 -18000 0 CST}
{2846466000 -14400 1 CDT}
{2867029200 -18000 0 CST}
{2877915600 -14400 1 CDT}
{2898478800 -18000 0 CST}
{2909365200 -14400 1 CDT}
{2929928400 -18000 0 CST}
{2940814800 -14400 1 CDT}
{2961378000 -18000 0 CST}
{2972264400 -14400 1 CDT}
{2992827600 -18000 0 CST}
{3003714000 -14400 1 CDT}
{3024277200 -18000 0 CST}
{3035768400 -14400 1 CDT}
{3056331600 -18000 0 CST}
{3067218000 -14400 1 CDT}
{3087781200 -18000 0 CST}
{3098667600 -14400 1 CDT}
{3119230800 -18000 0 CST}
{3130117200 -14400 1 CDT}
{3150680400 -18000 0 CST}
{3161566800 -14400 1 CDT}
{3182130000 -18000 0 CST}
{3193016400 -14400 1 CDT}
{3213579600 -18000 0 CST}
{3225070800 -14400 1 CDT}
{3245634000 -18000 0 CST}
{3256520400 -14400 1 CDT}
{3277083600 -18000 0 CST}
{3287970000 -14400 1 CDT}
{3308533200 -18000 0 CST}
{3319419600 -14400 1 CDT}
{3339982800 -18000 0 CST}
{3350869200 -14400 1 CDT}
{3371432400 -18000 0 CST}
{3382923600 -14400 1 CDT}
{3403486800 -18000 0 CST}
{3414373200 -14400 1 CDT}
{3434936400 -18000 0 CST}
{3445822800 -14400 1 CDT}
{3466386000 -18000 0 CST}
{3477272400 -14400 1 CDT}
{3497835600 -18000 0 CST}
{3508722000 -14400 1 CDT}
{3529285200 -18000 0 CST}
{3540171600 -14400 1 CDT}
{3560734800 -18000 0 CST}
{3572226000 -14400 1 CDT}
{3592789200 -18000 0 CST}
{3603675600 -14400 1 CDT}
{3624238800 -18000 0 CST}
{3635125200 -14400 1 CDT}
{3655688400 -18000 0 CST}
{3666574800 -14400 1 CDT}
{3687138000 -18000 0 CST}
{3698024400 -14400 1 CDT}
{3718587600 -18000 0 CST}
{3730078800 -14400 1 CDT}
{3750642000 -18000 0 CST}
{3761528400 -14400 1 CDT}
{3782091600 -18000 0 CST}
{3792978000 -14400 1 CDT}
{3813541200 -18000 0 CST}
{3824427600 -14400 1 CDT}
{3844990800 -18000 0 CST}
{3855877200 -14400 1 CDT}
{3876440400 -18000 0 CST}
{3887326800 -14400 1 CDT}
{3907890000 -18000 0 CST}
{3919381200 -14400 1 CDT}
{3939944400 -18000 0 CST}
{3950830800 -14400 1 CDT}
{3971394000 -18000 0 CST}
{3982280400 -14400 1 CDT}
{4002843600 -18000 0 CST}
{4013730000 -14400 1 CDT}
{4034293200 -18000 0 CST}
{4045179600 -14400 1 CDT}
{4065742800 -18000 0 CST}
{4076629200 -14400 1 CDT}
{4097192400 -18000 0 CST}
}
|
Changes to library/tzdata/Asia/Amman.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
{1238104800 10800 1 EEST}
{1256853600 7200 0 EET}
{1269554400 10800 1 EEST}
{1288303200 7200 0 EET}
{1301608800 10800 1 EEST}
{1319752800 7200 0 EET}
{1333058400 10800 1 EEST}
| < | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
{1238104800 10800 1 EEST}
{1256853600 7200 0 EET}
{1269554400 10800 1 EEST}
{1288303200 7200 0 EET}
{1301608800 10800 1 EEST}
{1319752800 7200 0 EET}
{1333058400 10800 1 EEST}
{1364504400 10800 1 EEST}
{1382652000 7200 0 EET}
{1395957600 10800 1 EEST}
{1414706400 7200 0 EET}
{1427407200 10800 1 EEST}
{1446156000 7200 0 EET}
{1459461600 10800 1 EEST}
{1477605600 7200 0 EET}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Gaza.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
{1238104800 10800 1 EEST}
{1252018800 7200 0 EET}
{1269640860 10800 1 EEST}
{1281474000 7200 0 EET}
{1301738460 10800 1 EEST}
{1312146000 7200 0 EET}
{1333058400 10800 1 EEST}
| | | 93 94 95 96 97 98 99 100 101 |
{1238104800 10800 1 EEST}
{1252018800 7200 0 EET}
{1269640860 10800 1 EEST}
{1281474000 7200 0 EET}
{1301738460 10800 1 EEST}
{1312146000 7200 0 EET}
{1333058400 10800 1 EEST}
{1348178400 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Hebron.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
{1269640860 10800 1 EEST}
{1281474000 7200 0 EET}
{1301652060 10800 1 EEST}
{1312146000 7200 0 EET}
{1314655200 10800 1 EEST}
{1317340800 7200 0 EET}
{1333058400 10800 1 EEST}
| | | 96 97 98 99 100 101 102 103 104 |
{1269640860 10800 1 EEST}
{1281474000 7200 0 EET}
{1301652060 10800 1 EEST}
{1312146000 7200 0 EET}
{1314655200 10800 1 EEST}
{1317340800 7200 0 EET}
{1333058400 10800 1 EEST}
{1348178400 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Jerusalem.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
{1269561600 10800 1 IDT}
{1284246000 7200 0 IST}
{1301616000 10800 1 IDT}
{1317510000 7200 0 IST}
{1333065600 10800 1 IDT}
{1348354800 7200 0 IST}
{1364515200 10800 1 IDT}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
{1269561600 10800 1 IDT}
{1284246000 7200 0 IST}
{1301616000 10800 1 IDT}
{1317510000 7200 0 IST}
{1333065600 10800 1 IDT}
{1348354800 7200 0 IST}
{1364515200 10800 1 IDT}
{1381014000 7200 0 IST}
{1395964800 10800 1 IDT}
{1412463600 7200 0 IST}
{1427414400 10800 1 IDT}
{1443913200 7200 0 IST}
{1458864000 10800 1 IDT}
{1475362800 7200 0 IST}
{1490313600 10800 1 IDT}
{1507417200 7200 0 IST}
{1521763200 10800 1 IDT}
{1538866800 7200 0 IST}
{1553817600 10800 1 IDT}
{1570316400 7200 0 IST}
{1585267200 10800 1 IDT}
{1601766000 7200 0 IST}
{1616716800 10800 1 IDT}
{1633215600 7200 0 IST}
{1648166400 10800 1 IDT}
{1664665200 7200 0 IST}
{1679616000 10800 1 IDT}
{1696719600 7200 0 IST}
{1711670400 10800 1 IDT}
{1728169200 7200 0 IST}
{1743120000 10800 1 IDT}
{1759618800 7200 0 IST}
{1774569600 10800 1 IDT}
{1791068400 7200 0 IST}
{1806019200 10800 1 IDT}
{1822604400 7200 0 IST}
{1837468800 10800 1 IDT}
{1854572400 7200 0 IST}
{1868918400 10800 1 IDT}
{1886022000 7200 0 IST}
{1900972800 10800 1 IDT}
{1917471600 7200 0 IST}
{1932422400 10800 1 IDT}
{1948921200 7200 0 IST}
{1963872000 10800 1 IDT}
{1980370800 7200 0 IST}
{1995321600 10800 1 IDT}
{2011820400 7200 0 IST}
{2026771200 10800 1 IDT}
{2043874800 7200 0 IST}
{2058220800 10800 1 IDT}
{2075324400 7200 0 IST}
{2090275200 10800 1 IDT}
{2106774000 7200 0 IST}
{2121724800 10800 1 IDT}
{2138223600 7200 0 IST}
{2153174400 10800 1 IDT}
{2169673200 7200 0 IST}
{2184624000 10800 1 IDT}
{2201122800 7200 0 IST}
{2216073600 10800 1 IDT}
{2233177200 7200 0 IST}
{2248128000 10800 1 IDT}
{2264626800 7200 0 IST}
{2279577600 10800 1 IDT}
{2296076400 7200 0 IST}
{2311027200 10800 1 IDT}
{2327526000 7200 0 IST}
{2342476800 10800 1 IDT}
{2358975600 7200 0 IST}
{2373926400 10800 1 IDT}
{2391030000 7200 0 IST}
{2405376000 10800 1 IDT}
{2422479600 7200 0 IST}
{2437430400 10800 1 IDT}
{2453929200 7200 0 IST}
{2468880000 10800 1 IDT}
{2485378800 7200 0 IST}
{2500329600 10800 1 IDT}
{2516828400 7200 0 IST}
{2531779200 10800 1 IDT}
{2548278000 7200 0 IST}
{2563228800 10800 1 IDT}
{2580332400 7200 0 IST}
{2595283200 10800 1 IDT}
{2611782000 7200 0 IST}
{2626732800 10800 1 IDT}
{2643231600 7200 0 IST}
{2658182400 10800 1 IDT}
{2674681200 7200 0 IST}
{2689632000 10800 1 IDT}
{2706130800 7200 0 IST}
{2721081600 10800 1 IDT}
{2738185200 7200 0 IST}
{2752531200 10800 1 IDT}
{2769634800 7200 0 IST}
{2784585600 10800 1 IDT}
{2801084400 7200 0 IST}
{2816035200 10800 1 IDT}
{2832534000 7200 0 IST}
{2847484800 10800 1 IDT}
{2863983600 7200 0 IST}
{2878934400 10800 1 IDT}
{2895433200 7200 0 IST}
{2910384000 10800 1 IDT}
{2927487600 7200 0 IST}
{2941833600 10800 1 IDT}
{2958937200 7200 0 IST}
{2973888000 10800 1 IDT}
{2990386800 7200 0 IST}
{3005337600 10800 1 IDT}
{3021836400 7200 0 IST}
{3036787200 10800 1 IDT}
{3053286000 7200 0 IST}
{3068236800 10800 1 IDT}
{3084735600 7200 0 IST}
{3099686400 10800 1 IDT}
{3116790000 7200 0 IST}
{3131740800 10800 1 IDT}
{3148239600 7200 0 IST}
{3163190400 10800 1 IDT}
{3179689200 7200 0 IST}
{3194640000 10800 1 IDT}
{3211138800 7200 0 IST}
{3226089600 10800 1 IDT}
{3242588400 7200 0 IST}
{3257539200 10800 1 IDT}
{3274642800 7200 0 IST}
{3288988800 10800 1 IDT}
{3306092400 7200 0 IST}
{3321043200 10800 1 IDT}
{3337542000 7200 0 IST}
{3352492800 10800 1 IDT}
{3368991600 7200 0 IST}
{3383942400 10800 1 IDT}
{3400441200 7200 0 IST}
{3415392000 10800 1 IDT}
{3431890800 7200 0 IST}
{3446841600 10800 1 IDT}
{3463945200 7200 0 IST}
{3478896000 10800 1 IDT}
{3495394800 7200 0 IST}
{3510345600 10800 1 IDT}
{3526844400 7200 0 IST}
{3541795200 10800 1 IDT}
{3558294000 7200 0 IST}
{3573244800 10800 1 IDT}
{3589743600 7200 0 IST}
{3604694400 10800 1 IDT}
{3621798000 7200 0 IST}
{3636144000 10800 1 IDT}
{3653247600 7200 0 IST}
{3668198400 10800 1 IDT}
{3684697200 7200 0 IST}
{3699648000 10800 1 IDT}
{3716146800 7200 0 IST}
{3731097600 10800 1 IDT}
{3747596400 7200 0 IST}
{3762547200 10800 1 IDT}
{3779046000 7200 0 IST}
{3793996800 10800 1 IDT}
{3811100400 7200 0 IST}
{3825446400 10800 1 IDT}
{3842550000 7200 0 IST}
{3857500800 10800 1 IDT}
{3873999600 7200 0 IST}
{3888950400 10800 1 IDT}
{3905449200 7200 0 IST}
{3920400000 10800 1 IDT}
{3936898800 7200 0 IST}
{3951849600 10800 1 IDT}
{3968348400 7200 0 IST}
{3983299200 10800 1 IDT}
{4000402800 7200 0 IST}
{4015353600 10800 1 IDT}
{4031852400 7200 0 IST}
{4046803200 10800 1 IDT}
{4063302000 7200 0 IST}
{4078252800 10800 1 IDT}
{4094751600 7200 0 IST}
}
|
Changes to library/tzdata/Pacific/Apia.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Apia) {
{-9223372036854775808 45184 0 LMT}
{-2855737984 -41216 0 LMT}
{-1861878784 -41400 0 SAMT}
{-631110600 -39600 0 WST}
{1285498800 -36000 1 WSDT}
{1301752800 -39600 0 WST}
{1316872800 -36000 1 WSDT}
{1325239200 50400 1 WSDT}
{1333202400 46800 0 WST}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Apia) {
{-9223372036854775808 45184 0 LMT}
{-2855737984 -41216 0 LMT}
{-1861878784 -41400 0 SAMT}
{-631110600 -39600 0 WST}
{1285498800 -36000 1 WSDT}
{1301752800 -39600 0 WST}
{1316872800 -36000 1 WSDT}
{1325239200 50400 1 WSDT}
{1333202400 46800 0 WST}
{1348927200 50400 1 WSDT}
{1365256800 46800 0 WST}
{1380376800 50400 1 WSDT}
{1396706400 46800 0 WST}
{1411826400 50400 1 WSDT}
{1428156000 46800 0 WST}
{1443276000 50400 1 WSDT}
{1459605600 46800 0 WST}
{1474725600 50400 1 WSDT}
{1491055200 46800 0 WST}
{1506175200 50400 1 WSDT}
{1522504800 46800 0 WST}
{1538229600 50400 1 WSDT}
{1554559200 46800 0 WST}
{1569679200 50400 1 WSDT}
{1586008800 46800 0 WST}
{1601128800 50400 1 WSDT}
{1617458400 46800 0 WST}
{1632578400 50400 1 WSDT}
{1648908000 46800 0 WST}
{1664028000 50400 1 WSDT}
{1680357600 46800 0 WST}
{1695477600 50400 1 WSDT}
{1712412000 46800 0 WST}
{1727532000 50400 1 WSDT}
{1743861600 46800 0 WST}
{1758981600 50400 1 WSDT}
{1775311200 46800 0 WST}
{1790431200 50400 1 WSDT}
{1806760800 46800 0 WST}
{1821880800 50400 1 WSDT}
{1838210400 46800 0 WST}
{1853330400 50400 1 WSDT}
{1869660000 46800 0 WST}
{1885384800 50400 1 WSDT}
{1901714400 46800 0 WST}
{1916834400 50400 1 WSDT}
{1933164000 46800 0 WST}
{1948284000 50400 1 WSDT}
{1964613600 46800 0 WST}
{1979733600 50400 1 WSDT}
{1996063200 46800 0 WST}
{2011183200 50400 1 WSDT}
{2027512800 46800 0 WST}
{2042632800 50400 1 WSDT}
{2058962400 46800 0 WST}
{2074687200 50400 1 WSDT}
{2091016800 46800 0 WST}
{2106136800 50400 1 WSDT}
{2122466400 46800 0 WST}
{2137586400 50400 1 WSDT}
{2153916000 46800 0 WST}
{2169036000 50400 1 WSDT}
{2185365600 46800 0 WST}
{2200485600 50400 1 WSDT}
{2216815200 46800 0 WST}
{2232540000 50400 1 WSDT}
{2248869600 46800 0 WST}
{2263989600 50400 1 WSDT}
{2280319200 46800 0 WST}
{2295439200 50400 1 WSDT}
{2311768800 46800 0 WST}
{2326888800 50400 1 WSDT}
{2343218400 46800 0 WST}
{2358338400 50400 1 WSDT}
{2374668000 46800 0 WST}
{2389788000 50400 1 WSDT}
{2406117600 46800 0 WST}
{2421842400 50400 1 WSDT}
{2438172000 46800 0 WST}
{2453292000 50400 1 WSDT}
{2469621600 46800 0 WST}
{2484741600 50400 1 WSDT}
{2501071200 46800 0 WST}
{2516191200 50400 1 WSDT}
{2532520800 46800 0 WST}
{2547640800 50400 1 WSDT}
{2563970400 46800 0 WST}
{2579090400 50400 1 WSDT}
{2596024800 46800 0 WST}
{2611144800 50400 1 WSDT}
{2627474400 46800 0 WST}
{2642594400 50400 1 WSDT}
{2658924000 46800 0 WST}
{2674044000 50400 1 WSDT}
{2690373600 46800 0 WST}
{2705493600 50400 1 WSDT}
{2721823200 46800 0 WST}
{2736943200 50400 1 WSDT}
{2753272800 46800 0 WST}
{2768997600 50400 1 WSDT}
{2785327200 46800 0 WST}
{2800447200 50400 1 WSDT}
{2816776800 46800 0 WST}
{2831896800 50400 1 WSDT}
{2848226400 46800 0 WST}
{2863346400 50400 1 WSDT}
{2879676000 46800 0 WST}
{2894796000 50400 1 WSDT}
{2911125600 46800 0 WST}
{2926245600 50400 1 WSDT}
{2942575200 46800 0 WST}
{2958300000 50400 1 WSDT}
{2974629600 46800 0 WST}
{2989749600 50400 1 WSDT}
{3006079200 46800 0 WST}
{3021199200 50400 1 WSDT}
{3037528800 46800 0 WST}
{3052648800 50400 1 WSDT}
{3068978400 46800 0 WST}
{3084098400 50400 1 WSDT}
{3100428000 46800 0 WST}
{3116152800 50400 1 WSDT}
{3132482400 46800 0 WST}
{3147602400 50400 1 WSDT}
{3163932000 46800 0 WST}
{3179052000 50400 1 WSDT}
{3195381600 46800 0 WST}
{3210501600 50400 1 WSDT}
{3226831200 46800 0 WST}
{3241951200 50400 1 WSDT}
{3258280800 46800 0 WST}
{3273400800 50400 1 WSDT}
{3289730400 46800 0 WST}
{3305455200 50400 1 WSDT}
{3321784800 46800 0 WST}
{3336904800 50400 1 WSDT}
{3353234400 46800 0 WST}
{3368354400 50400 1 WSDT}
{3384684000 46800 0 WST}
{3399804000 50400 1 WSDT}
{3416133600 46800 0 WST}
{3431253600 50400 1 WSDT}
{3447583200 46800 0 WST}
{3462703200 50400 1 WSDT}
{3479637600 46800 0 WST}
{3494757600 50400 1 WSDT}
{3511087200 46800 0 WST}
{3526207200 50400 1 WSDT}
{3542536800 46800 0 WST}
{3557656800 50400 1 WSDT}
{3573986400 46800 0 WST}
{3589106400 50400 1 WSDT}
{3605436000 46800 0 WST}
{3620556000 50400 1 WSDT}
{3636885600 46800 0 WST}
{3652610400 50400 1 WSDT}
{3668940000 46800 0 WST}
{3684060000 50400 1 WSDT}
{3700389600 46800 0 WST}
{3715509600 50400 1 WSDT}
{3731839200 46800 0 WST}
{3746959200 50400 1 WSDT}
{3763288800 46800 0 WST}
{3778408800 50400 1 WSDT}
{3794738400 46800 0 WST}
{3809858400 50400 1 WSDT}
{3826188000 46800 0 WST}
{3841912800 50400 1 WSDT}
{3858242400 46800 0 WST}
{3873362400 50400 1 WSDT}
{3889692000 46800 0 WST}
{3904812000 50400 1 WSDT}
{3921141600 46800 0 WST}
{3936261600 50400 1 WSDT}
{3952591200 46800 0 WST}
{3967711200 50400 1 WSDT}
{3984040800 46800 0 WST}
{3999765600 50400 1 WSDT}
{4016095200 46800 0 WST}
{4031215200 50400 1 WSDT}
{4047544800 46800 0 WST}
{4062664800 50400 1 WSDT}
{4078994400 46800 0 WST}
{4094114400 50400 1 WSDT}
}
|
Changes to library/tzdata/Pacific/Fakaofo.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fakaofo) {
{-9223372036854775808 -41096 0 LMT}
| | | | 1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Fakaofo) {
{-9223372036854775808 -41096 0 LMT}
{-2177411704 -39600 0 TKT}
{1325242800 46800 0 TKT}
}
|
Changes to library/tzdata/Pacific/Fiji.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 |
{951573600 43200 0 FJT}
{1259416800 46800 1 FJST}
{1269698400 43200 0 FJT}
{1287842400 46800 1 FJST}
{1299333600 43200 0 FJT}
{1319292000 46800 1 FJST}
{1327154400 43200 0 FJT}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
{951573600 43200 0 FJT}
{1259416800 46800 1 FJST}
{1269698400 43200 0 FJT}
{1287842400 46800 1 FJST}
{1299333600 43200 0 FJT}
{1319292000 46800 1 FJST}
{1327154400 43200 0 FJT}
{1350741600 46800 1 FJST}
{1358604000 43200 0 FJT}
{1382191200 46800 1 FJST}
{1390053600 43200 0 FJT}
{1413640800 46800 1 FJST}
{1421503200 43200 0 FJT}
{1445090400 46800 1 FJST}
{1453557600 43200 0 FJT}
{1477144800 46800 1 FJST}
{1485007200 43200 0 FJT}
{1508594400 46800 1 FJST}
{1516456800 43200 0 FJT}
{1540044000 46800 1 FJST}
{1547906400 43200 0 FJT}
{1571493600 46800 1 FJST}
{1579356000 43200 0 FJT}
{1602943200 46800 1 FJST}
{1611410400 43200 0 FJT}
{1634997600 46800 1 FJST}
{1642860000 43200 0 FJT}
{1666447200 46800 1 FJST}
{1674309600 43200 0 FJT}
{1697896800 46800 1 FJST}
{1705759200 43200 0 FJT}
{1729346400 46800 1 FJST}
{1737208800 43200 0 FJT}
{1760796000 46800 1 FJST}
{1768658400 43200 0 FJT}
{1792245600 46800 1 FJST}
{1800712800 43200 0 FJT}
{1824300000 46800 1 FJST}
{1832162400 43200 0 FJT}
{1855749600 46800 1 FJST}
{1863612000 43200 0 FJT}
{1887199200 46800 1 FJST}
{1895061600 43200 0 FJT}
{1918648800 46800 1 FJST}
{1926511200 43200 0 FJT}
{1950098400 46800 1 FJST}
{1957960800 43200 0 FJT}
{1982152800 46800 1 FJST}
{1990015200 43200 0 FJT}
{2013602400 46800 1 FJST}
{2021464800 43200 0 FJT}
{2045052000 46800 1 FJST}
{2052914400 43200 0 FJT}
{2076501600 46800 1 FJST}
{2084364000 43200 0 FJT}
{2107951200 46800 1 FJST}
{2115813600 43200 0 FJT}
{2139400800 46800 1 FJST}
{2147868000 43200 0 FJT}
{2171455200 46800 1 FJST}
{2179317600 43200 0 FJT}
{2202904800 46800 1 FJST}
{2210767200 43200 0 FJT}
{2234354400 46800 1 FJST}
{2242216800 43200 0 FJT}
{2265804000 46800 1 FJST}
{2273666400 43200 0 FJT}
{2297253600 46800 1 FJST}
{2305116000 43200 0 FJT}
{2328703200 46800 1 FJST}
{2337170400 43200 0 FJT}
{2360757600 46800 1 FJST}
{2368620000 43200 0 FJT}
{2392207200 46800 1 FJST}
{2400069600 43200 0 FJT}
{2423656800 46800 1 FJST}
{2431519200 43200 0 FJT}
{2455106400 46800 1 FJST}
{2462968800 43200 0 FJT}
{2486556000 46800 1 FJST}
{2495023200 43200 0 FJT}
{2518610400 46800 1 FJST}
{2526472800 43200 0 FJT}
{2550060000 46800 1 FJST}
{2557922400 43200 0 FJT}
{2581509600 46800 1 FJST}
{2589372000 43200 0 FJT}
{2612959200 46800 1 FJST}
{2620821600 43200 0 FJT}
{2644408800 46800 1 FJST}
{2652271200 43200 0 FJT}
{2675858400 46800 1 FJST}
{2684325600 43200 0 FJT}
{2707912800 46800 1 FJST}
{2715775200 43200 0 FJT}
{2739362400 46800 1 FJST}
{2747224800 43200 0 FJT}
{2770812000 46800 1 FJST}
{2778674400 43200 0 FJT}
{2802261600 46800 1 FJST}
{2810124000 43200 0 FJT}
{2833711200 46800 1 FJST}
{2841573600 43200 0 FJT}
{2865765600 46800 1 FJST}
{2873628000 43200 0 FJT}
{2897215200 46800 1 FJST}
{2905077600 43200 0 FJT}
{2928664800 46800 1 FJST}
{2936527200 43200 0 FJT}
{2960114400 46800 1 FJST}
{2967976800 43200 0 FJT}
{2991564000 46800 1 FJST}
{2999426400 43200 0 FJT}
{3023013600 46800 1 FJST}
{3031480800 43200 0 FJT}
{3055068000 46800 1 FJST}
{3062930400 43200 0 FJT}
{3086517600 46800 1 FJST}
{3094380000 43200 0 FJT}
{3117967200 46800 1 FJST}
{3125829600 43200 0 FJT}
{3149416800 46800 1 FJST}
{3157279200 43200 0 FJT}
{3180866400 46800 1 FJST}
{3188728800 43200 0 FJT}
{3212316000 46800 1 FJST}
{3220783200 43200 0 FJT}
{3244370400 46800 1 FJST}
{3252232800 43200 0 FJT}
{3275820000 46800 1 FJST}
{3283682400 43200 0 FJT}
{3307269600 46800 1 FJST}
{3315132000 43200 0 FJT}
{3338719200 46800 1 FJST}
{3346581600 43200 0 FJT}
{3370168800 46800 1 FJST}
{3378636000 43200 0 FJT}
{3402223200 46800 1 FJST}
{3410085600 43200 0 FJT}
{3433672800 46800 1 FJST}
{3441535200 43200 0 FJT}
{3465122400 46800 1 FJST}
{3472984800 43200 0 FJT}
{3496572000 46800 1 FJST}
{3504434400 43200 0 FJT}
{3528021600 46800 1 FJST}
{3535884000 43200 0 FJT}
{3559471200 46800 1 FJST}
{3567938400 43200 0 FJT}
{3591525600 46800 1 FJST}
{3599388000 43200 0 FJT}
{3622975200 46800 1 FJST}
{3630837600 43200 0 FJT}
{3654424800 46800 1 FJST}
{3662287200 43200 0 FJT}
{3685874400 46800 1 FJST}
{3693736800 43200 0 FJT}
{3717324000 46800 1 FJST}
{3725186400 43200 0 FJT}
{3749378400 46800 1 FJST}
{3757240800 43200 0 FJT}
{3780828000 46800 1 FJST}
{3788690400 43200 0 FJT}
{3812277600 46800 1 FJST}
{3820140000 43200 0 FJT}
{3843727200 46800 1 FJST}
{3851589600 43200 0 FJT}
{3875176800 46800 1 FJST}
{3883039200 43200 0 FJT}
{3906626400 46800 1 FJST}
{3915093600 43200 0 FJT}
{3938680800 46800 1 FJST}
{3946543200 43200 0 FJT}
{3970130400 46800 1 FJST}
{3977992800 43200 0 FJT}
{4001580000 46800 1 FJST}
{4009442400 43200 0 FJT}
{4033029600 46800 1 FJST}
{4040892000 43200 0 FJT}
{4064479200 46800 1 FJST}
{4072341600 43200 0 FJT}
{4095928800 46800 1 FJST}
}
|
Changes to macosx/Tcl.xcode/project.pbxproj.
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
F96D442E08F272B8004A47F5 /* man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html.tcl; sourceTree = "<group>"; };
F96D442F08F272B8004A47F5 /* man2html1.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html1.tcl; sourceTree = "<group>"; };
F96D443008F272B8004A47F5 /* man2html2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html2.tcl; sourceTree = "<group>"; };
F96D443108F272B8004A47F5 /* man2tcl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = man2tcl.c; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
F96D443508F272B8004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
| < | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
F96D442E08F272B8004A47F5 /* man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html.tcl; sourceTree = "<group>"; };
F96D442F08F272B8004A47F5 /* man2html1.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html1.tcl; sourceTree = "<group>"; };
F96D443008F272B8004A47F5 /* man2html2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html2.tcl; sourceTree = "<group>"; };
F96D443108F272B8004A47F5 /* man2tcl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = man2tcl.c; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
F96D443508F272B8004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "tcltk-man2html.tcl"; sourceTree = "<group>"; };
F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = "<group>"; };
F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = "<group>"; };
F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = "<group>"; };
F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
F96D444208F272B9004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1682 1683 1684 1685 1686 1687 1688 | F96D442E08F272B8004A47F5 /* man2html.tcl */, F96D442F08F272B8004A47F5 /* man2html1.tcl */, F96D443008F272B8004A47F5 /* man2html2.tcl */, F96D443108F272B8004A47F5 /* man2tcl.c */, F96D443208F272B8004A47F5 /* README */, F96D443308F272B8004A47F5 /* regexpTestLib.tcl */, F96D443508F272B8004A47F5 /* tcl.hpj.in */, | < | 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 | F96D442E08F272B8004A47F5 /* man2html.tcl */, F96D442F08F272B8004A47F5 /* man2html1.tcl */, F96D443008F272B8004A47F5 /* man2html2.tcl */, F96D443108F272B8004A47F5 /* man2tcl.c */, F96D443208F272B8004A47F5 /* README */, F96D443308F272B8004A47F5 /* regexpTestLib.tcl */, F96D443508F272B8004A47F5 /* tcl.hpj.in */, F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */, F96D443A08F272B9004A47F5 /* tclZIC.tcl */, F92D7F100DE777240033A13A /* tsdPerf.tcl */, F96D443B08F272B9004A47F5 /* uniClass.tcl */, F96D443C08F272B9004A47F5 /* uniParse.tcl */, ); path = tools; |
| ︙ | ︙ |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
F96D442E08F272B8004A47F5 /* man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html.tcl; sourceTree = "<group>"; };
F96D442F08F272B8004A47F5 /* man2html1.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html1.tcl; sourceTree = "<group>"; };
F96D443008F272B8004A47F5 /* man2html2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html2.tcl; sourceTree = "<group>"; };
F96D443108F272B8004A47F5 /* man2tcl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = man2tcl.c; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
F96D443508F272B8004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
| < | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
F96D442E08F272B8004A47F5 /* man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html.tcl; sourceTree = "<group>"; };
F96D442F08F272B8004A47F5 /* man2html1.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html1.tcl; sourceTree = "<group>"; };
F96D443008F272B8004A47F5 /* man2html2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html2.tcl; sourceTree = "<group>"; };
F96D443108F272B8004A47F5 /* man2tcl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = man2tcl.c; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
F96D443508F272B8004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "tcltk-man2html.tcl"; sourceTree = "<group>"; };
F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = "<group>"; };
F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = "<group>"; };
F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = "<group>"; };
F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
F96D444208F272B9004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1682 1683 1684 1685 1686 1687 1688 | F96D442E08F272B8004A47F5 /* man2html.tcl */, F96D442F08F272B8004A47F5 /* man2html1.tcl */, F96D443008F272B8004A47F5 /* man2html2.tcl */, F96D443108F272B8004A47F5 /* man2tcl.c */, F96D443208F272B8004A47F5 /* README */, F96D443308F272B8004A47F5 /* regexpTestLib.tcl */, F96D443508F272B8004A47F5 /* tcl.hpj.in */, | < | 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 | F96D442E08F272B8004A47F5 /* man2html.tcl */, F96D442F08F272B8004A47F5 /* man2html1.tcl */, F96D443008F272B8004A47F5 /* man2html2.tcl */, F96D443108F272B8004A47F5 /* man2tcl.c */, F96D443208F272B8004A47F5 /* README */, F96D443308F272B8004A47F5 /* regexpTestLib.tcl */, F96D443508F272B8004A47F5 /* tcl.hpj.in */, F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */, F96D443A08F272B9004A47F5 /* tclZIC.tcl */, F92D7F100DE777240033A13A /* tsdPerf.tcl */, F96D443B08F272B9004A47F5 /* uniClass.tcl */, F96D443C08F272B9004A47F5 /* uniParse.tcl */, ); path = tools; |
| ︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclMacOSXFCmd.c * * This file implements the MacOSX specific portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 2003-2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifdef HAVE_GETATTRLIST #include <sys/attr.h> #include <sys/paths.h> #include <libkern/OSByteOrder.h> #endif | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclMacOSXFCmd.c * * This file implements the MacOSX specific portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 2003-2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <sys/stat.h> #include "tclInt.h" #ifdef HAVE_GETATTRLIST #include <sys/attr.h> #include <sys/paths.h> #include <libkern/OSByteOrder.h> #endif |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
finderinfo *finder = (finderinfo *) &finfo.data;
off_t *rsrcForkSize = (off_t *) &finfo.data;
const char *native;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
| > | | | | > | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
finderinfo *finder = (finderinfo *) &finfo.data;
off_t *rsrcForkSize = (off_t *) &finfo.data;
const char *native;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) {
/*
* Directories only support attribute "-hidden".
*/
errno = EISDIR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid attribute: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
native = Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
switch (objIndex) {
case MACOSX_CREATOR_ATTRIBUTE:
*attributePtrPtr = NewOSTypeObj(
OSSwapBigToHostInt32(finder->creator));
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
break;
case MACOSX_RSRCLENGTH_ATTRIBUTE:
*attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize);
break;
}
return TCL_OK;
#else
| > | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
break;
case MACOSX_RSRCLENGTH_ATTRIBUTE:
*attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize);
break;
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
return TCL_ERROR;
#endif /* HAVE_GETATTRLIST */
}
/*
*---------------------------------------------------------------------------
*
* TclMacOSXSetFileAttribute --
*
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
finderinfo *finder = (finderinfo *) &finfo.data;
off_t *rsrcForkSize = (off_t *) &finfo.data;
const char *native;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
| > | | | | > | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
finderinfo *finder = (finderinfo *) &finfo.data;
off_t *rsrcForkSize = (off_t *) &finfo.data;
const char *native;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) {
/*
* Directories only support attribute "-hidden".
*/
errno = EISDIR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid attribute: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
native = Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
if (objIndex != MACOSX_RSRCLENGTH_ATTRIBUTE) {
OSType t;
int h;
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
break;
}
result = setattrlist(native, &alist,
&finfo.data, sizeof(finfo.data), 0);
if (result != 0) {
| > | | < | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
break;
}
result = setattrlist(native, &alist,
&finfo.data, sizeof(finfo.data), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
} else {
Tcl_WideInt newRsrcForkSize;
if (Tcl_GetWideIntFromObj(interp, attributePtr,
&newRsrcForkSize) != TCL_OK) {
return TCL_ERROR;
}
if (newRsrcForkSize != *rsrcForkSize) {
Tcl_DString ds;
/*
* Only setting rsrclength to 0 to strip a file's resource fork is
* supported.
*/
if (newRsrcForkSize != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"setting nonzero rsrclength not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
return TCL_ERROR;
}
/*
* Construct path to resource fork.
*/
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
result = close(fd);
}
}
Tcl_DStringFree(&ds);
if (result != 0) {
| | | | < > | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
result = close(fd);
}
}
Tcl_DStringFree(&ds);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not truncate resource fork of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
return TCL_ERROR;
#endif
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_UtfToExternalDString(encoding, string, length, &ds);
if (Tcl_DStringLength(&ds) > 4) {
if (interp) {
| > | < | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_UtfToExternalDString(encoding, string, length, &ds);
if (Tcl_DStringLength(&ds) > 4) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected Macintosh OS type but got \"%s\": ", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL);
}
result = TCL_ERROR;
} else {
OSType osType;
char bytes[4] = {'\0','\0','\0','\0'};
|
| ︙ | ︙ |
Changes to pkgs/README.
|
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
The 'pkgs' subdirectory of the Tcl source code distribution is meant to be
a place where the source code distribution of Tcl packages may be placed so
that they are built, installed, and tested along with Tcl. As originally
distributed, Tcl re-distributes a number of packages in this location. The
build systems for Tcl are written so that additional packages may be added,
or the original packages removed in any number and still have all packages
present get built, installed, and tested along with Tcl.
In order for a package to work properly under the pkgs subdirectory, it
needs to conform to the following conventions.
All files of the package need to be contained in (subdirs of ...) a
single subdirectory of the "pkgs" directrory.
In that subdirectory of "pkgs" there must be an executable file named
"configure". When the program "configure" is run, it should generate
a file "Makefile" in the current working directory. The "configure"
program should be able to accept as command line arguments all the
arguments that can be passed to the master unix/configure program. It
should also accept the --with-tcl= and --with-tclinclude= options in
the conventional way.
The generated "Makefile" must be one suitable for controlling the operations
of a `make` program. The following targets must be defined:
<default>: Perform a build of the runtime components of the
package from sources.
install: Copy the runtime components of the package into their
installed location. Must respect the DESTDIR variable
for determining the installation location.
test: Run the test suite of the package. Must respect the
TCLSH_PROG, TESTFLAGS variables.
clean: Delete all files generated by the default build target.
distclean: Delete all generated files.
dist: Produce a copy of the package's source code distribution.
Must respect the DIST_ROOT variable determing where to
write the generated directory.
Packages that are written to make use of the Tcl Extension Architecture (TEA)
and that make use of the tclconfig collection of support files, should
conform to these conventions without further efforts.
These conventions are subject to revision and refinement over time to
better support the needs of the build system. Efforts will be made to
keep the TEA support scripts consistent with the demands of this system.
In addition, it is requested that packages also support building with
Microsoft Visual Studio tools. This means the file win/makefile.vc
should be included, suitable for use by the nmake program, defining the
targets <default>, install, test, and clean.
|
Changes to pkgs/msgcat/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | > | | > < < < < | < < < < < | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > | > > > > > | < > | | | < | | | > | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | < < < < < < < < < < < | | | | > > | > > > | > > > > < | | | < | | | > > > > > | | > > > | | > > | | > > > > > > > < < < < | < > > > > > | < | > > > > > > > > > > > > > > > > > > > > > > | < < < | < | < < < < < > > < < < < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.61 for msgcat 1.5.0.
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization. ##
## --------------------- ##
# Be 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
# 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
# PATH needs CR
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
echo "#! /bin/sh" >conf$$.sh
echo "exit 0" >>conf$$.sh
chmod +x conf$$.sh
if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
PATH_SEPARATOR=';'
else
PATH_SEPARATOR=:
fi
rm -f conf$$.sh
fi
# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
as_unset=unset
else
as_unset=false
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.)
as_nl='
'
IFS=" "" $as_nl"
# Find who we are. Look in the path if we contain no directory separator.
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
echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
{ (exit 1); exit 1; }
fi
# Work around bugs in pre-3.0 UWIN ksh.
for as_var in ENV MAIL MAILPATH
do ($as_unset $as_var) >/dev/null 2>&1 && $as_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) >/dev/null 2>&1 && $as_unset $as_var
fi
done
# Required to use basename.
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
as_basename=basename
else
as_basename=false
fi
# Name of the executable.
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
}
/^X\/\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
# CDPATH.
$as_unset CDPATH
if test "x$CONFIG_SHELL" = x; then
if (eval ":") 2>/dev/null; then
as_have_required=yes
else
as_have_required=no
fi
if test $as_have_required = yes && (eval ":
(as_func_return () {
(exit \$1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test \$exitcode = 0) || { (exit 1); exit 1; }
(
as_lineno_1=\$LINENO
as_lineno_2=\$LINENO
test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&
test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }
") 2> /dev/null; then
:
else
as_candidate_shells=
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=.
case $as_dir in
/*)
for as_base in sh bash ksh sh5; do
as_candidate_shells="$as_candidate_shells $as_dir/$as_base"
done;;
esac
done
IFS=$as_save_IFS
for as_shell in $as_candidate_shells $SHELL; do
# Try only shells that exist, to save several forks.
if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
{ ("$as_shell") 2> /dev/null <<\_ASEOF
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
:
_ASEOF
}; then
CONFIG_SHELL=$as_shell
as_have_required=yes
if { "$as_shell" 2> /dev/null <<\_ASEOF
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
:
(as_func_return () {
(exit $1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = "$1" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test $exitcode = 0) || { (exit 1); exit 1; }
(
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }
_ASEOF
}; then
break
fi
fi
done
if test "x$CONFIG_SHELL" != x; then
for as_var in BASH_ENV ENV
do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
done
export CONFIG_SHELL
exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}
fi
if test $as_have_required = no; then
echo This script requires a shell more modern than all the
echo shells that I found on your system. Please install a
echo modern shell, or manually run the script under such a
echo shell if you do have one.
{ (exit 1); exit 1; }
fi
fi
fi
(eval "as_func_return () {
(exit \$1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test \$exitcode = 0") || {
echo No shell found that supports shell functions.
echo Please tell autoconf@gnu.org about your system,
echo including any error possibly output before this
echo message
}
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
# 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 after each line using $LINENO; the second 'sed'
# does the real work. The second script uses 'N' to pair each
# line-number line with the line containing $LINENO, 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
# scripts with optimization help from Paolo Bonzini. Blame Lee
# E. McMahon (1931-1989) for sed's syntax. :-)
sed -n '
p
/[$]LINENO/=
' <$as_myself |
sed '
s/[$]LINENO.*/&-/
t lineno
b
:lineno
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
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; }; }
# 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 sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in
-n*)
case `echo 'x\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
*) ECHO_C='\c';;
esac;;
*)
ECHO_N='-n';;
esac
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir
fi
echo >conf$$.file
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 -p'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
as_ln_s='cp -p'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
as_mkdir_p=:
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
if test -x / >/dev/null 2>&1; then
as_test_x='test -x'
else
if ls -dL / >/dev/null 2>&1; then
as_ls_L_option=L
else
as_ls_L_option=
fi
as_test_x='
eval sh -c '\''
if test -d "$1"; then
test -d "$1/.";
else
case $1 in
-*)set "./$1";;
esac;
case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
???[sx]*):;;*)false;;esac;fi
'\'' sh
'
fi
as_executable_p=$as_test_x
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
exec 7<&0 </dev/null 6>&1
# Name of the host.
# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
# so uname gets run too.
ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
#
# 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}
# Identity of this package.
PACKAGE_NAME='msgcat'
PACKAGE_TARNAME='msgcat'
PACKAGE_VERSION='1.5.0'
PACKAGE_STRING='msgcat 1.5.0'
PACKAGE_BUGREPORT=''
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
datarootdir
datadir
sysconfdir
sharedstatedir
localstatedir
includedir
oldincludedir
docdir
infodir
htmldir
dvidir
pdfdir
psdir
libdir
localedir
mandir
DEFS
ECHO_C
ECHO_N
ECHO_T
LIBS
build_alias
host_alias
target_alias
LIBOBJS
LTLIBOBJS'
ac_subst_files=''
ac_precious_vars='build_alias
host_alias
target_alias'
# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
# The variables have the same names as the options, with
# dashes changed to underlines.
cache_file=/dev/null
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 302 303 304 |
x_libraries=NONE
# Installation directory options.
# These are left unexpanded so users can "make install exec_prefix=/foo"
# and all the variables that are supposed to be based on exec_prefix
# by default will actually change.
# Use braces instead of parens because sh, perl, etc. also accept them.
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
| > | > < > | > > > > > > | > | > | > > | > > | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
x_libraries=NONE
# Installation directory options.
# These are left unexpanded so users can "make install exec_prefix=/foo"
# and all the variables that are supposed to be based on exec_prefix
# by default will actually change.
# Use braces instead of parens because sh, perl, etc. also accept them.
# (The list follows the same order as the GNU Coding Standards.)
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
includedir='${prefix}/include'
oldincludedir='/usr/include'
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
ac_prev=
continue
fi
case $ac_option in
*=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
*) ac_optarg=yes ;;
esac
# Accept the important Cygnus configure options, so we can diagnose typos.
case $ac_dashdash$ac_option in
--)
ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
-bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
bindir=$ac_optarg ;;
-build | --build | --buil | --bui | --bu)
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
-cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
| --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
cache_file=$ac_optarg ;;
--config-cache | -C)
cache_file=config.cache ;;
| | | > > > | > > > | | | | > > > > > > > > > > | | < < < < | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 |
-cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
| --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
cache_file=$ac_optarg ;;
--config-cache | -C)
cache_file=config.cache ;;
-datadir | --datadir | --datadi | --datad)
ac_prev=datadir ;;
-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-\(.*\)'`
# 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 ;;
-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-\([^=]*\)'`
# 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=\$ac_optarg ;;
-exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
| --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
| --exec | --exe | --ex)
ac_prev=exec_prefix ;;
-exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
| --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
-help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
ac_init_help=short ;;
-host | --host | --hos | --ho)
ac_prev=host_alias ;;
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
-includedir | --includedir | --includedi | --included | --include \
| --includ | --inclu | --incl | --inc)
ac_prev=includedir ;;
-includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
| --includ=* | --inclu=* | --incl=* | --inc=*)
includedir=$ac_optarg ;;
| > > > > > > | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
-help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
ac_init_help=short ;;
-host | --host | --hos | --ho)
ac_prev=host_alias ;;
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
-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 ;;
-includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
| --includ=* | --inclu=* | --incl=* | --inc=*)
includedir=$ac_optarg ;;
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 427 428 |
-libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
| --libexe | --libex | --libe)
ac_prev=libexecdir ;;
-libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
| --libexe=* | --libex=* | --libe=*)
libexecdir=$ac_optarg ;;
-localstatedir | --localstatedir | --localstatedi | --localstated \
| > > > > > | < | < | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
-libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
| --libexe | --libex | --libe)
ac_prev=libexecdir ;;
-libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
| --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)
ac_prev=localstatedir ;;
-localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
| --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
localstatedir=$ac_optarg ;;
-mandir | --mandir | --mandi | --mand | --man | --ma | --m)
ac_prev=mandir ;;
-mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
mandir=$ac_optarg ;;
|
| ︙ | ︙ | |||
491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
| --program-transform-nam=* | --program-transform-na=* \
| --program-transform-n=* | --program-transform-=* \
| --program-transform=* | --program-transfor=* \
| --program-transfo=* | --program-transf=* \
| --program-trans=* | --program-tran=* \
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
| > > > > > > > > > > | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 |
| --program-transform-nam=* | --program-transform-na=* \
| --program-transform-n=* | --program-transform-=* \
| --program-transform=* | --program-transfor=* \
| --program-transfo=* | --program-transf=* \
| --program-trans=* | --program-tran=* \
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
-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 ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
| | | < < < < | | | | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid package name: $ac_package" >&2
{ (exit 1); exit 1; }; }
ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
eval with_$ac_package=\$ac_optarg ;;
-without-* | --without-*)
ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid package name: $ac_package" >&2
{ (exit 1); exit 1; }; }
ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
eval with_$ac_package=no ;;
--x)
# Obsolete; use --with-x.
with_x=yes ;;
-x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
| --x-incl | --x-inc | --x-in | --x-i)
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
*=*)
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; }; }
| < | | | > > > | | | < < < < < < < < < < | | < | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 |
*=*)
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; }; }
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
echo "$as_me: WARNING: you should use --build, --host, --target" >&2
expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
echo "$as_me: WARNING: invalid host type: $ac_option" >&2
: ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
;;
esac
done
if test -n "$ac_prev"; then
ac_option=--`echo $ac_prev | sed 's/_/-/g'`
{ echo "$as_me: error: missing argument to $ac_option" >&2
{ (exit 1); exit 1; }; }
fi
# Be sure to have absolute directory names.
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=\$$ac_var
case $ac_val in
[\\/$]* | ?:[\\/]* ) continue;;
NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
esac
{ echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
{ (exit 1); exit 1; }; }
done
# There might be people who depend on the old broken behavior: `$host'
# used to hold the argument of --host etc.
# FIXME: To remove some day.
build=$build_alias
host=$host_alias
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 666 667 668 669 | fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes | > > > > > > > > > > | | | < | > > > | > > > | > > > | > > > | | | | < < < | | < < | > > > > > | < > | | | | | | | | | | | > | < < < < > > | > | > > > > > | > < | | > > | | > > > > | | | > > | < | < | < | | > | | | < | < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | | | | | | | < < | < < | | | | | > | | | < | | > | > | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
fi
ac_tool_prefix=
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 .` ||
{ echo "$as_me: error: Working directory cannot be determined" >&2
{ (exit 1); exit 1; }; }
test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
{ echo "$as_me: error: pwd does not report name of working directory" >&2
{ (exit 1); exit 1; }; }
# 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 the parent directory.
ac_confdir=`$as_dirname -- "$0" ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$0" : 'X\(//\)[^/]' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$0" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
srcdir=$ac_confdir
if test ! -r "$srcdir/$ac_unique_file"; then
srcdir=..
fi
else
ac_srcdir_defaulted=no
fi
if test ! -r "$srcdir/$ac_unique_file"; then
test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
{ echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
{ (exit 1); exit 1; }; }
fi
ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
ac_abs_confdir=`(
cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2
{ (exit 1); exit 1; }; }
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.
#
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 msgcat 1.5.0 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE. See below for descriptions of some of the useful variables.
Defaults for the options are specified in brackets.
Configuration:
-h, --help display this help and exit
--help=short display options specific to this package
--help=recursive display the short help of all the included packages
-V, --version display version information and exit
-q, --quiet, --silent do not print \`checking...' messages
--cache-file=FILE cache test results in FILE [disabled]
-C, --config-cache alias for \`--cache-file=config.cache'
-n, --no-create do not create output files
--srcdir=DIR find the sources in DIR [configure dir or \`..']
Installation directories:
--prefix=PREFIX install architecture-independent files in PREFIX
[$ac_default_prefix]
--exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
[PREFIX]
By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.
For better control, use the options below.
Fine tuning of the installation directories:
--bindir=DIR user executables [EPREFIX/bin]
--sbindir=DIR system admin executables [EPREFIX/sbin]
--libexecdir=DIR program executables [EPREFIX/libexec]
--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/msgcat]
--htmldir=DIR html documentation [DOCDIR]
--dvidir=DIR dvi documentation [DOCDIR]
--pdfdir=DIR pdf documentation [DOCDIR]
--psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
_ACEOF
fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of msgcat 1.5.0:";;
esac
cat <<\_ACEOF
_ACEOF
ac_status=$?
fi
if test "$ac_init_help" = "recursive"; then
# If there are subdirs, report their specific --help.
for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
test -d "$ac_dir" || continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`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
.) # We are building in place.
ac_srcdir=.
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
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
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 || ac_status=$?
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
msgcat configure 1.5.0
generated by GNU Autoconf 2.61
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
2002, 2003, 2004, 2005, 2006 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
fi
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 msgcat $as_me 1.5.0, which was
generated by GNU Autoconf 2.61. Invocation command line was
$ $0 $@
_ACEOF
exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
## Platform. ##
## --------- ##
hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
uname -m = `(uname -m) 2>/dev/null || echo unknown`
uname -r = `(uname -r) 2>/dev/null || echo unknown`
uname -s = `(uname -s) 2>/dev/null || echo unknown`
uname -v = `(uname -v) 2>/dev/null || echo unknown`
/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
/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`
_ASUNAME
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
echo "PATH: $as_dir"
done
IFS=$as_save_IFS
} >&5
cat >&5 <<_ACEOF
## ----------- ##
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 | # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= | < | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 |
# Strip out --no-create and --no-recursion so they do not pile up.
# Strip out --silent because we don't want to record it for future runs.
# Also quote any args containing shell meta-characters.
# Make two passes to allow for proper duplicate-argument suppression.
ac_configure_args=
ac_configure_args0=
ac_configure_args1=
ac_must_keep_next=false
for ac_pass in 1 2
do
for ac_arg
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
2)
ac_configure_args1="$ac_configure_args1 '$ac_arg'"
if test $ac_must_keep_next = true; then
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
case "$ac_configure_args0 " in
"$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
esac
;;
-* ) ac_must_keep_next=true ;;
esac
fi
| | < < | | > > > > | > > > > > > > > > > | | | | | < | | < > > | > > > | | | | | > > > | | | | | | < < | 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
case "$ac_configure_args0 " in
"$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
esac
;;
-* ) ac_must_keep_next=true ;;
esac
fi
ac_configure_args="$ac_configure_args '$ac_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; }
# 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: 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
## ---------------- ##
## 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_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
*) $as_unset $ac_var ;;
esac ;;
esac
done
(set) 2>&1 |
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"
;; #(
*)
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
cat <<\_ASBOX
## ----------------- ##
## Output variables. ##
## ----------------- ##
_ASBOX
echo
for ac_var in $ac_subst_vars
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
echo "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
cat <<\_ASBOX
## ------------------- ##
## File substitutions. ##
## ------------------- ##
_ASBOX
echo
for ac_var in $ac_subst_files
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
echo "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
echo
cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
echo "$as_me: caught signal $ac_signal"
echo "$as_me: exit $exit_status"
} >&5
rm -f core *.core core.conftest.* &&
rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
' 0
for ac_signal in 1 2 13 15; do
trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -f -r conftest* confdefs.h
# Predefined preprocessor variables.
cat >>confdefs.h <<_ACEOF
#define PACKAGE_NAME "$PACKAGE_NAME"
_ACEOF
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 | cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer explicitly selected file to automatically selected ones. | | > | | | > | | | | > | | | < | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 |
cat >>confdefs.h <<_ACEOF
#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
_ACEOF
# Let the site file select an alternate cache file if it wants to.
# Prefer explicitly selected file to automatically selected ones.
if test -n "$CONFIG_SITE"; then
set x "$CONFIG_SITE"
elif test "x$prefix" != xNONE; then
set x "$prefix/share/config.site" "$prefix/etc/config.site"
else
set x "$ac_default_prefix/share/config.site" \
"$ac_default_prefix/etc/config.site"
fi
shift
for ac_site_file
do
if test -r "$ac_site_file"; then
{ echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
echo "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
. "$ac_site_file"
fi
done
if test -r "$cache_file"; then
# Some versions of bash will fail to source /dev/null (special
# files actually), so we avoid doing that.
if test -f "$cache_file"; then
{ echo "$as_me:$LINENO: loading cache $cache_file" >&5
echo "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
[\\/]* | ?:[\\/]* ) . "$cache_file";;
*) . "./$cache_file";;
esac
fi
else
{ echo "$as_me:$LINENO: creating cache $cache_file" >&5
echo "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in $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
case $ac_old_set,$ac_new_set in
set,)
{ echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
ac_cache_corrupted=: ;;
,set)
{ echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 |
echo "$as_me: current value: $ac_new_val" >&2;}
ac_cache_corrupted=:
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
| < | > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > > > > | | | | < | | > | > | | | | | | > > > | < < < < < < < < < < < < < < < | | | | | < > | | | | | > > > > > > | < < < < < < < < > > | < > | < | > | | | 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 |
echo "$as_me: current value: $ac_new_val" >&2;}
ac_cache_corrupted=:
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
*\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
*) ac_arg=$ac_var=$ac_new_val ;;
esac
case " $ac_configure_args " in
*" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
*) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
esac
fi
done
if $ac_cache_corrupted; then
{ echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
echo "$as_me: error: changes in the environment can compromise the build" >&2;}
{ { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
{ (exit 1); exit 1; }; }
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
ac_config_files="$ac_config_files Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs, see configure's option --config-cache.
# It is not useful on other systems. If it contains results you don't
# want to keep, you may remove or edit it.
#
# config.status only pays attention to the cache file if you give it
# the --recheck option to rerun configure.
#
# `ac_cv_env_foo' variables (set or unset) will be overridden when
# loading this file, other *unset* `ac_cv_foo' will be assigned the
# following values.
_ACEOF
# The following way of writing the cache mishandles newlines in values,
# but we know of no workaround that is simple, portable, and efficient.
# So, 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_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
*) $as_unset $ac_var ;;
esac ;;
esac
done
(set) 2>&1 |
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 "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
t end
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 "$as_me:$LINENO: updating cache $cache_file" >&5
echo "$as_me: updating cache $cache_file" >&6;}
cat confcache >$cache_file
else
{ echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5
echo "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
# 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 branch to the quote section. Otherwise,
# look for a macro that doesn't take arguments.
ac_script='
t clear
:clear
s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
t quote
s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g
t quote
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=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
# 1. Remove the extension, and $U if already installed.
ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
ac_i=`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.
ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"
ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs
LTLIBOBJS=$ac_ltlibobjs
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## | | > < < < < | < < < < < | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > | > > > > > | < > | | | < | | | > | | | | | | | | < | | | | > > > > | > > | > | > > > > > > > > > | > > > > > > > | > > > > > | | > > > > > > > > > > > > > > > > > > > | > > | > > < | < < < < < < < < < < < | | | | > > | > > > | > > > > < | | | < | < | | | > > > > > | | > > > | | > > | | > > > > > > > < < < < | < > > > > > | < | > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < | | < < < < < < < < | | | < | > | > | < < < < < | < < < < < < < < | < > | | | | > > | | | | < < < < < < | | < < < < < < < < < | | | < < < < | | | > | > > | | | | > > > > > > > > > > > | < | > > | | > > > | > > < | | | < | < < < | | | > | | | > > > > | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > < < < < < | < < < < | | | > > > | > > > > > > | > > > | > > > > > | > > > > > > | > | < > > > > > > > > > | | > > > > > > > > > > > > > > > > > | | < | | < < | | | > > > | | > | < < < | > | < < < < < < | < | < > | | | | > | > > > > > > > > > > > > > > > > > | | > > > > > | > > > | < < < < < | < | < < < < | > < | | < | > > > | > > > | > > > | > > > | < | | | > > | | > > > > | | < | > > > | > > > | > > > | > > > | > | | | < | > > | | > > > > | | | > > | < | < | < | | > | | | < | < < < < < < < < < < < < < < < < < < < < < < < | | | < < | > > > > | > | < > > > | < < < < > | | < < < < < < < < < < < < < < < | < < > > | > > | | | < < | | > > | < | > | | < | < | < < < < < < | < > > > > | > | | | | | | | > > | > > > > > > > | | | | > | > | | | > | < < | 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 |
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
## --------------------- ##
## 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
# 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
# PATH needs CR
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
echo "#! /bin/sh" >conf$$.sh
echo "exit 0" >>conf$$.sh
chmod +x conf$$.sh
if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
PATH_SEPARATOR=';'
else
PATH_SEPARATOR=:
fi
rm -f conf$$.sh
fi
# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
as_unset=unset
else
as_unset=false
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.)
as_nl='
'
IFS=" "" $as_nl"
# Find who we are. Look in the path if we contain no directory separator.
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
echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
{ (exit 1); exit 1; }
fi
# Work around bugs in pre-3.0 UWIN ksh.
for as_var in ENV MAIL MAILPATH
do ($as_unset $as_var) >/dev/null 2>&1 && $as_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) >/dev/null 2>&1 && $as_unset $as_var
fi
done
# Required to use basename.
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
as_basename=basename
else
as_basename=false
fi
# Name of the executable.
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
}
/^X\/\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
# CDPATH.
$as_unset CDPATH
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
# 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 after each line using $LINENO; the second 'sed'
# does the real work. The second script uses 'N' to pair each
# line-number line with the line containing $LINENO, 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
# scripts with optimization help from Paolo Bonzini. Blame Lee
# E. McMahon (1931-1989) for sed's syntax. :-)
sed -n '
p
/[$]LINENO/=
' <$as_myself |
sed '
s/[$]LINENO.*/&-/
t lineno
b
:lineno
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
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; }; }
# 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 sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in
-n*)
case `echo 'x\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
*) ECHO_C='\c';;
esac;;
*)
ECHO_N='-n';;
esac
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir
fi
echo >conf$$.file
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 -p'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
as_ln_s='cp -p'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
as_mkdir_p=:
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
if test -x / >/dev/null 2>&1; then
as_test_x='test -x'
else
if ls -dL / >/dev/null 2>&1; then
as_ls_L_option=L
else
as_ls_L_option=
fi
as_test_x='
eval sh -c '\''
if test -d "$1"; then
test -d "$1/.";
else
case $1 in
-*)set "./$1";;
esac;
case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
???[sx]*):;;*)false;;esac;fi
'\'' sh
'
fi
as_executable_p=$as_test_x
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
exec 6>&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.
ac_log="
This file was extended by msgcat $as_me 1.5.0, which was
generated by GNU Autoconf 2.61. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
CONFIG_LINKS = $CONFIG_LINKS
CONFIG_COMMANDS = $CONFIG_COMMANDS
$ $0 $@
on `(hostname || uname -n) 2>/dev/null | sed 1q`
"
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
# Files that config.status was made for.
config_files="$ac_config_files"
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
ac_cs_usage="\
\`$as_me' instantiates files from templates according to the
current configuration.
Usage: $0 [OPTIONS] [FILE]...
-h, --help print this help, then exit
-V, --version print version number and configuration settings, then exit
-q, --quiet do not print progress messages
-d, --debug don't remove temporary files
--recheck update $as_me by reconfiguring in the same conditions
--file=FILE[:TEMPLATE]
instantiate the configuration file FILE
Configuration files:
$config_files
Report bugs to <bug-autoconf@gnu.org>."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
msgcat config.status 1.5.0
configured by $0, generated by GNU Autoconf 2.61,
with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
Copyright (C) 2006 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
ac_pwd='$ac_pwd'
srcdir='$srcdir'
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default
# value. By we need to know if files were specified by the user.
ac_need_defaults=:
while test $# != 0
do
case $1 in
--*=*)
ac_option=`expr "X$1" : 'X\([^=]*\)='`
ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
ac_shift=:
;;
*)
ac_option=$1
ac_optarg=$2
ac_shift=shift
;;
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
echo "$ac_cs_version"; exit ;;
--debug | --debu | --deb | --de | --d | -d )
debug=: ;;
--file | --fil | --fi | --f )
$ac_shift
CONFIG_FILES="$CONFIG_FILES $ac_optarg"
ac_need_defaults=false;;
--he | --h | --help | --hel | -h )
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: error: unrecognized option: $1
Try \`$0 --help' for more information." >&2
{ (exit 1); exit 1; }; } ;;
*) ac_config_targets="$ac_config_targets $1"
ac_need_defaults=false ;;
esac
shift
done
ac_configure_extra_args=
if $ac_cs_silent; then
exec 6>/dev/null
ac_configure_extra_args="$ac_configure_extra_args --silent"
fi
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
if \$ac_cs_recheck; then
echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
CONFIG_SHELL=$SHELL
export CONFIG_SHELL
exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
fi
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
exec 5>>config.log
{
echo
sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
echo "$ac_log"
} >&5
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# Handling of arguments.
for ac_config_target in $ac_config_targets
do
case $ac_config_target in
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
*) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
{ (exit 1); exit 1; }; };;
esac
done
# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used. Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
fi
# Have a temporary directory for convenience. Make it in the build tree
# simply because there is no reason against having it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# 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 ||
{
tmp=
trap 'exit_status=$?
{ test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status
' 0
trap '{ (exit 1); exit 1; }' 1 2 13 15
}
# Create a (secure) tmp directory for tmp files.
{
tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
test -n "$tmp" && test -d "$tmp"
} ||
{
tmp=./conf$$-$RANDOM
(umask 077 && mkdir "$tmp")
} ||
{
echo "$me: cannot create a temporary directory in ." >&2
{ (exit 1); exit 1; }
}
#
# Set up the sed scripts for 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
_ACEOF
ac_delim='%!_!# '
for ac_last_try in false false false false false :; do
cat >conf$$subs.sed <<_ACEOF
SHELL!$SHELL$ac_delim
PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim
PACKAGE_NAME!$PACKAGE_NAME$ac_delim
PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim
PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim
PACKAGE_STRING!$PACKAGE_STRING$ac_delim
PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim
exec_prefix!$exec_prefix$ac_delim
prefix!$prefix$ac_delim
program_transform_name!$program_transform_name$ac_delim
bindir!$bindir$ac_delim
sbindir!$sbindir$ac_delim
libexecdir!$libexecdir$ac_delim
datarootdir!$datarootdir$ac_delim
datadir!$datadir$ac_delim
sysconfdir!$sysconfdir$ac_delim
sharedstatedir!$sharedstatedir$ac_delim
localstatedir!$localstatedir$ac_delim
includedir!$includedir$ac_delim
oldincludedir!$oldincludedir$ac_delim
docdir!$docdir$ac_delim
infodir!$infodir$ac_delim
htmldir!$htmldir$ac_delim
dvidir!$dvidir$ac_delim
pdfdir!$pdfdir$ac_delim
psdir!$psdir$ac_delim
libdir!$libdir$ac_delim
localedir!$localedir$ac_delim
mandir!$mandir$ac_delim
DEFS!$DEFS$ac_delim
ECHO_C!$ECHO_C$ac_delim
ECHO_N!$ECHO_N$ac_delim
ECHO_T!$ECHO_T$ac_delim
LIBS!$LIBS$ac_delim
build_alias!$build_alias$ac_delim
host_alias!$host_alias$ac_delim
target_alias!$target_alias$ac_delim
LIBOBJS!$LIBOBJS$ac_delim
LTLIBOBJS!$LTLIBOBJS$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 39; then
break
elif $ac_last_try; then
{ { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}
{ (exit 1); exit 1; }; }
else
ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
fi
done
ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`
if test -n "$ac_eof"; then
ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`
ac_eof=`expr $ac_eof + 1`
fi
cat >>$CONFIG_STATUS <<_ACEOF
cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end
_ACEOF
sed '
s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g
s/^/s,@/; s/!/@,|#_!!_#|/
:n
t n
s/'"$ac_delim"'$/,g/; t
s/$/\\/; p
N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n
' >>$CONFIG_STATUS <conf$$subs.sed
rm -f conf$$subs.sed
cat >>$CONFIG_STATUS <<_ACEOF
:end
s/|#_!!_#|//g
CEOF$ac_eof
_ACEOF
# 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
cat >>$CONFIG_STATUS <<\_ACEOF
fi # test -n "$CONFIG_FILES"
for ac_tag in :F $CONFIG_FILES
do
case $ac_tag in
:[FHLC]) ac_mode=$ac_tag; continue;;
esac
case $ac_mode$ac_tag in
:[FHL]*:*);;
:L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5
echo "$as_me: error: Invalid tag $ac_tag." >&2;}
{ (exit 1); exit 1; }; };;
:[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
case $ac_mode in
:L) ac_source=$1;;
:[FH])
ac_file_inputs=
for ac_f
do
case $ac_f in
-) ac_f="$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 ||
{ { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5
echo "$as_me: error: cannot find input file: $ac_f" >&2;}
{ (exit 1); exit 1; }; };;
esac
ac_file_inputs="$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 "`IFS=:
echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."
if test x"$ac_file" != x-; then
configure_input="$ac_file. $configure_input"
{ echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
fi
case $ac_tag in
*:-:* | *:-) cat >"$tmp/stdin";;
esac
;;
esac
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'`
{ as_dir="$ac_dir"
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`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 ||
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" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5
echo "$as_me: error: cannot create directory $as_dir" >&2;}
{ (exit 1); exit 1; }; }; }
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`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
.) # We are building in place.
ac_srcdir=.
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
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
case $ac_mode in
:F)
#
# CONFIG_FILE
#
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# 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=
case `sed -n '/datarootdir/ {
p
q
}
/@datadir@/p
/@docdir@/p
/@infodir@/p
/@localedir@/p
/@mandir@/p
' $ac_file_inputs` in
*datarootdir*) ac_datarootdir_seen=yes;;
*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
{ echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
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
# 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
sed "$ac_vpsub
$extrasub
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
:t
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
s&@configure_input@&$configure_input&;t t
s&@top_builddir@&$ac_top_builddir_sub&;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
" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&
{ echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined." >&5
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 "$tmp/stdin"
case $ac_file in
-) cat "$tmp/out"; rm -f "$tmp/out";;
*) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;
esac
;;
esac
done # for ac_tag
{ (exit 0); exit 0; }
_ACEOF
chmod +x $CONFIG_STATUS
ac_clean_files=$ac_clean_files_save
|
| ︙ | ︙ |
Changes to pkgs/msgcat/configure.in.
|
| | | 1 2 | AC_INIT([msgcat], [1.5.0]) AC_OUTPUT([Makefile]) |
Changes to pkgs/msgcat/doc/AddErrInfo.3.
| ︙ | ︙ | |||
103 104 105 106 107 108 109 | \fB\-errorcode\fR, and \fB\-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB\-code\fR and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | \fB\-errorcode\fR, and \fB\-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB\-code\fR and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting any entries in it, without the need to check for a shared value. As with any \fBTcl_Obj\fR with reference count of zero, it is up to the caller to arrange for its disposal with \fBTcl_DecrRefCount\fR or to a reference to it via \fBTcl_IncrRefCount\fR (or one of the many functions that call that, notably including \fBTcl_SetObjResult\fR and \fBTcl_SetVar2Ex\fR). .PP A typical usage for \fBTcl_GetReturnOptions\fR is to |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the | | | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the \fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR built up by the caller. \fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .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. .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full |
| ︙ | ︙ | |||
305 306 307 308 309 310 311 | \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), tclvars(n) .SH KEYWORDS | | | 305 306 307 308 309 310 311 312 | \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), Tcl_SetErrno(3), tclvars(n) .SH KEYWORDS error, value, value result, stack, trace, variable |
Changes to pkgs/msgcat/doc/BoolObj.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP int *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS | | | 88 89 90 91 92 93 94 95 | while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS boolean, value |
Changes to pkgs/msgcat/doc/ByteArrObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 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. '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | '\" '\" Copyright (c) 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. '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) .sp void \fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) .sp unsigned char * \fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. .AP int length in The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array value, it will be converted to one. .AP int *lengthPtr out If non-NULL, filled with the length of the array of bytes in the value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl byte-array values from C code. Byte-array values are typically used to hold the results of binary IO operations or data structures created with the \fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a string. Conceptually, a string is an array of Unicode characters, while a byte-array is an array of 8-bit quantities with no implicit meaning. Accessor functions are provided to get the string representation of a byte-array or to convert an arbitrary value to a byte-array. Obtaining the string representation of a byte-array value (by calling \fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the UTF-8 characters in the string representation. .PP \fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will create a new value of byte-array type or modify an existing value to have a byte-array type. Both of these procedures set the value's type to be byte-array and set the value's internal representation to a copy of the array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a pointer to a newly allocated value with a reference count of zero. \fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if the value is not already a byte-array value, frees any old internal representation. If \fIbytes\fR is NULL then the new byte array contains arbitrary values. .PP \fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and returns a pointer to the value's new internal representation as an array of bytes. The length of this array is stored in \fIlengthPtr\fR if \fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by the value and should not be freed. The contents of the array may be modified by the caller only if the value is not shared and the caller invalidates the string representation. .PP \fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type and changes the length of the value's internal representation as an array of bytes. If \fIlength\fR is greater than the space currently allocated for the array, the array is reallocated to the new length; the newly allocated bytes at the end of the array have arbitrary values. If \fIlength\fR is less than the space currently allocated for the array, the length of array is reduced to the new length. The return value is a pointer to the value's new array of bytes. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS value, binary data, byte array, utf, unicode, internationalization |
Changes to pkgs/msgcat/doc/CrtChannel.3.
| ︙ | ︙ | |||
246 247 248 249 250 251 252 | \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or | | | | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or output. The \fIsize\fR argument should be between one and one million, allowing buffers of one byte to one million bytes. If \fIsize\fR is outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have occurred on the channel. Channel drivers are responsible for invoking this function whenever the channel handlers need to be called for the |
| ︙ | ︙ | |||
842 843 844 845 846 847 848 | (optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP It always returns \fBTCL_ERROR\fR .PP | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
(optional) interpreter. It is used by channel drivers when
an invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
the generic options error message string.
.PP
It always returns \fBTCL_ERROR\fR
.PP
An error message is generated in \fIinterp\fR's result value to
indicate that a command was invoked with a bad option.
The message has the form
.CS
bad option "blah": should be one of
<...generic options...>+<...specific options...>
.CE
so you get for instance:
|
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/CrtCommand.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of | | | | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of argument strings instead of values. The value-based command procedures registered by \fBTcl_CreateObjCommand\fR can execute significantly faster than the string-based command procedures defined by \fBTcl_CreateCommand\fR. This is because they take Tcl values as arguments and those values can retain an internal representation that can be manipulated more efficiently. Also, Tcl's interpreter now uses values internally. In order to invoke a string-based command procedure registered by \fBTcl_CreateCommand\fR, it must generate and fetch a string representation from each argument value before the call. New commands should be defined using \fBTcl_CreateObjCommand\fR. We support \fBTcl_CreateCommand\fR for backwards compatibility. .PP The procedures \fBTcl_DeleteCommand\fR, \fBTcl_GetCommandInfo\fR, and \fBTcl_SetCommandInfo\fR are used in conjunction with \fBTcl_CreateCommand\fR. .PP |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/CrtMathFnc.3.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH "NOTICE OF EVENTUAL DEPRECATION" .PP The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions are rendered somewhat obsolete by the ability to create functions for expressions by placing commands in the \fBtcl::mathfunc\fR namespace, as described in the \fBmathfunc\fR manual page; the API described on this page is not expected to be maintained indefinitely. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp |
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP \fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all the math functions defined in the interpreter whose name matches \fIpattern\fR. The returned value has a reference count of zero. .SH "SEE ALSO" expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) .SH KEYWORDS expression, mathematical function |
Changes to pkgs/msgcat/doc/CrtObjCmd.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in Value containing the name of a Tcl command. .BE .SH DESCRIPTION .PP \fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIname\fR is invoked as a Tcl command (e.g., via a call to \fBTcl_EvalObjEx\fR) |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | .CE .PP When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the | | | | | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | .CE .PP When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the arguments to the command, \fIobjc\fR giving the number of argument values (including the command name) and \fIobjv\fR giving the values of the arguments. The \fIobjv\fR array will contain \fIobjc\fR values, pointing to the argument values. Unlike \fIargv\fR[\fIargv\fR] used in a string-based command procedure, \fIobjv\fR[\fIobjc\fR] will not contain NULL. .PP Additionally, when \fIproc\fR is invoked, it must not modify the contents of the \fIobjv\fR array by assigning new pointer values to any element of the array (for example, \fIobjv\fR[\fB2\fR] = \fBNULL\fR) because this will cause memory to be lost and the runtime stack to be corrupted. The \fBconst\fR in the declaration of \fIobjv\fR will cause ANSI-compliant compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual value argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that value; that call may change the type of the value that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, if \fIproc\fR needs to return a non-empty result, it can call \fBTcl_SetObjResult\fR to set the interpreter's result. In the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR this gives an error message. Before invoking a command procedure, \fBTcl_EvalObjEx\fR sets interpreter's result to point to a value representing an empty string, so simple commands can return an empty result by doing nothing at all. .PP The contents of the \fIobjv\fR array belong to Tcl and are not guaranteed to persist once \fIproc\fR returns: \fIproc\fR should not modify them. Call \fBTcl_SetObjResult\fR if you want to return something from the \fIobjv\fR array. |
| ︙ | ︙ | |||
221 222 223 224 225 226 227 | It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; | | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 | It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; they hold information about the value-based command procedure that the Tcl interpreter calls to implement the command. The fields \fIproc\fR and \fIclientData\fR hold information about the string-based command procedure that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. The field \fIdeleteData\fR is the ClientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. The field \fInamespacePtr\fR holds a pointer to the Tcl_Namespace that contains the command. .PP |
| ︙ | ︙ | |||
286 287 288 289 290 291 292 | owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name of a command from a command token. The name, including all namespace prefixes, | | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name of a command from a command token. The name, including all namespace prefixes, is appended to the value specified by \fIobjPtr\fR. .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) .SH KEYWORDS bind, command, create, delete, namespace, value |
Changes to pkgs/msgcat/doc/CrtSlave.3.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in | | | | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "const char *const" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in Count of additional value arguments to pass to the aliased command. .AP Tcl_Obj **objv in Vector of Tcl_Obj structures, the additional value arguments to pass to the aliased command. This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target command is defined for an alias. .AP "const char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. .AP int *argcPtr out Pointer to location to store count of additional arguments to be passed to the alias. The location is in storage owned by the caller. .AP "const char" ***argvPtr out Pointer to location to store a vector of strings, the additional arguments to pass to an alias. The location is in storage owned by the caller, the vector of strings is owned by the called function. .AP int *objcPtr out Pointer to location to store count of additional value arguments to be passed to the alias. The location is in storage owned by the caller. .AP Tcl_Obj ***objvPtr out Pointer to location to store a vector of Tcl_Obj structures, the additional arguments to pass to an alias command. The location is in storage owned by the caller, the vector of Tcl_Obj structures is owned by the called function. .AP "const char" *cmdName in Name of an exposed command to hide or create. .AP "const char" *hiddenCmdName in Name under which a hidden command is stored and with which it can be exposed or invoked. |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | \fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and the \fIresult\fR field in \fIaskingInterp\fR contains the error message. .PP | | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | \fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and the \fIresult\fR field in \fIaskingInterp\fR contains the error message. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if it fails; in that case, an error message is left in the value result of \fIslaveInterp\fR. Note that there are no restrictions on the ancestry relationship (as created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP \fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP \fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in which case the corresponding datum is not returned. If a result field is non\-\fBNULL\fR, the address indicated is set to the corresponding datum. For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 | it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the \fIresult\fR field in \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message in the | | | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the \fIresult\fR field in \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message in the value result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. After executing this command, attempts to use \fIcmdName\fR in a call to \fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed. .PP \fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of exposed commands to the set of hidden commands, under the name \fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed command, or the operation will return \fBTCL_ERROR\fR and leave an error message in the value result of \fIinterp\fR. Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and leave an error message in the value result of \fIinterp\fR. The \fICmdName\fR will be looked up in the global namespace, and not relative to the current namespace, even if the current namespace is not the global one. If a hidden command whose name is \fIhiddenCmdName\fR already exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR field in \fIinterp\fR contains an error message. If the operation succeeds, it returns \fBTCL_OK\fR. |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/DictObj.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" 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_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" 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_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl values as dictionaries .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewDictObj\fR() .sp |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in | | | | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | \fBTcl_DictObjPutKeyList\fR(\fIinterp, dictPtr, keyc, keyv, valuePtr\fR) .sp int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in If an error occurs while converting a value to be a dictionary value, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP Tcl_Obj *dictPtr in/out Points to the dictionary value to be manipulated. If \fIdictPtr\fR does not already point to a dictionary value, an attempt will be made to convert it to one. .AP Tcl_Obj *keyPtr in Points to the key for the key/value pair being manipulated within the dictionary value. .AP Tcl_Obj **keyPtrPtr out Points to a variable that will have the key from a key/value pair placed within it. May be NULL to indicate that the caller is not interested in the key. .AP Tcl_Obj *valuePtr in Points to the value for the key/value pair being manipulated within the dictionary value (or sub-value, in the case of \fBTcl_DictObjPutKeyList\fR.) .AP Tcl_Obj **valuePtrPtr out Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. .AP int *sizePtr out |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in | | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | Points to a variable that will have a non-zero value written into it when the enumeration of the key/value pairs in a dictionary has completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in Array of \fIkeyc\fR pointers to values that \fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will use to locate the key/value pair to manipulate within the sub-dictionaries of the main dictionary value passed to them. .BE .SH DESCRIPTION .PP Tcl dictionary values have an internal representation that supports efficient mapping from keys to values and which guarantees that the particular ordering of keys within the dictionary remains the same modulo any keys being deleted (which removes them from the order) or added (which adds them to the end of the order). If reinterpreted as a list, the values at the even-valued indices in the list will be the keys of the dictionary, and each will be followed (in the odd-valued index) by the value associated with that key. .PP The procedures described in this man page are used to create, modify, index, and iterate over dictionary values from C code. .PP \fBTcl_NewDictObj\fR creates a new, empty dictionary value. The string representation of the value will be invalid, and the reference count of the value will be zero. .PP \fBTcl_DictObjGet\fR looks up the given key within the given dictionary and writes a pointer to the value associated with that key into the variable pointed to by \fIvaluePtrPtr\fR, or a NULL if the key has no mapping within the dictionary. The result of this procedure is \fBTCL_OK\fR, or \fBTCL_ERROR\fR if the \fIdictPtr\fR cannot be converted to a dictionary. |
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search,
&key, &value, &done) != TCL_OK) {
return TCL_ERROR;
}
for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) {
/*
* Note that strcmp() is not a good way of comparing
| | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search,
&key, &value, &done) != TCL_OK) {
return TCL_ERROR;
}
for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) {
/*
* Note that strcmp() is not a good way of comparing
* values and is just used here for demonstration
* purposes.
*/
if (!strcmp(Tcl_GetString(key), Tcl_GetString(value))) {
break;
}
}
\fBTcl_DictObjDone\fR(&search);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!done));
return TCL_OK;
.CE
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_InitObjHashTable
.SH KEYWORDS
dict, dict value, dictionary, dictionary value, hash table, iteration, value
|
Changes to pkgs/msgcat/doc/DoubleObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl values as floating-point values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewDoubleObj\fR(\fIdoubleValue\fR) .sp \fBTcl_SetDoubleObj\fR(\fIobjPtr, doubleValue\fR) .sp int \fBTcl_GetDoubleFromObj\fR(\fIinterp, objPtr, doublePtr\fR) .SH ARGUMENTS .AS Tcl_Interp doubleValue in/out .AP double doubleValue in A double-precision floating-point value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetDoubleObj\fR, this points to the value in which to store a double value. For \fBTcl_GetDoubleFromObj\fR, this refers to the value from which to retrieve a double value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when double value retrieval fails. .AP double *doublePtr out Points to place to store the double value obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl values that hold double-precision floating-point values. .PP \fBTcl_NewDoubleObj\fR creates and returns a new Tcl value initialized to the double value \fIdoubleValue\fR. The returned Tcl value is unshared. .PP \fBTcl_SetDoubleObj\fR sets the value of an existing Tcl value pointed to by \fIobjPtr\fR to the double value \fIdoubleValue\fR. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value 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 \fBTcl_GetDoubleFromObj\fR attempts to retrieve a double value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the double value is written to the storage pointed to by \fIdoublePtr\fR. 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 \fBTcl_GetDoubleFromObj\fR more efficient. '\" TODO: add discussion of treatment of NaN value .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS double, double value, double type, internal representation, value, value type, string representation |
Changes to pkgs/msgcat/doc/Eval.3.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. .AP int objc in The number of values in the array pointed to by \fIobjPtr\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in Points to an array of pointers to values; each value holds the value of a single word in the command to execute. .AP int numBytes in The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. It executes the commands in the script stored in \fIobjPtr\fR until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step can be skipped if the value is evaluated again in the future. .PP The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values | | | | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each value in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the elements of \fIobjv\fR, insuring that the values are valid until \fBTcl_EvalObjv\fR returns. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to be executed is supplied as a string instead of a value and no compilation occurs. The string should be a proper UTF-8 string as converted by \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known to possibly contain upper ASCII characters whose possible combinations might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to \fIinterp->result\fR (use is deprecated) where it can be accessed directly. This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which does not do the copy. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes additional arguments \fInumBytes\fR and \fIflags\fR. For the efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the contents of a value are going to change immediately, so the bytecodes will not be reused in a future execution. In this case, it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . If this flag is set, the script is processed at global level. This means that it is evaluated in the global namespace and its variable |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS | | | 204 205 206 207 208 209 210 211 | and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS execute, file, global, result, script, value |
Changes to pkgs/msgcat/doc/ExprLong.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the | | | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the value-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR. Those value-based procedures evaluate an expression held in a Tcl value instead of a string. The value argument can retain an internal representation that is more efficient to execute. .PP The \fIinterp\fR argument refers to an interpreter used to evaluate the expression (e.g. for variables and nested Tcl commands) and to return error information. .PP For all of these procedures the return value is a standard |
| ︙ | ︙ | |||
99 100 101 102 103 104 105 | \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS | | | 99 100 101 102 103 104 105 106 | \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS boolean, double, evaluate, expression, integer, value, string |
Changes to pkgs/msgcat/doc/ExprLongObj.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in | | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in Pointer to a value containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the expression. .AP int *booleanPtr out Pointer to location in which to store the 0/1 boolean value of the expression. .AP Tcl_Obj **resultPtrPtr out Pointer to location in which to store a pointer to the value that is the result of the expression. .BE .SH DESCRIPTION .PP These four procedures all evaluate an expression, returning the result in one of four different forms. |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | such as .QW yes or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, | | | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | such as .QW yes or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, it stores a pointer to the Tcl value containing the expression's value at \fI*resultPtrPtr\fR. In this case, the caller is responsible for calling \fBTcl_DecrRefCount\fR to decrement the value's reference count when it is finished with the value. .SH "SEE ALSO" Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult .SH KEYWORDS boolean, double, evaluate, expression, integer, value, string |
Changes to pkgs/msgcat/doc/FileSystem.3.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | .sp int \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | .sp int \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp const char *const * \fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR) .sp int \fBTcl_FSStat\fR(\fIpathPtr, statPtr\fR) .sp int \fBTcl_FSAccess\fR(\fIpathPtr, mode\fR) |
| ︙ | ︙ | |||
188 189 190 191 192 193 194 | .VE 8.6 .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in | | | | | | | | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | .VE 8.6 .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in The path represented by this value is used for the operation in question. If the value does not already have an internal \fBpath\fR representation, it will be converted to have one. .AP Tcl_Obj *srcPathPtr in As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. .AP Tcl_Obj *destPathPtr in As for \fIpathPtr\fR, but used for the destination filename for a copy or rename operation. .AP "const char" *encodingName in The encoding of the data stored in the file identified by \fIpathPtr\fR and to be evaluated. .AP "const char" *pattern in Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. .AP ClientData clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. .AP int elements in If non-negative, the number of elements in the \fIlistObj\fR which should be joined together. If negative, then all elements are joined. .AP Tcl_Obj **errorPtr out In the case of an error, filled with a value containing the name of the file which caused an error in the various copy/rename operations. .AP Tcl_Obj **objPtrRef out Filled with a value containing the result of the operation. .AP Tcl_Obj *resultPtr out Pre-allocated value in which to store (using \fBTcl_ListObjAppendElement\fR) the list of files or directories which are successfully matched. .AP int mode in Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK, W_OK and X_OK request checking whether the file exists and has read, write and execute permissions, respectively. F_OK just requests checking for the existence of the file. |
| ︙ | ︙ | |||
327 328 329 330 331 332 333 | listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP | | | | | | | | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP The \fBTcl_FS\fR API is \fBTcl_Obj\fR-ified and may cache internal representations and other path-related strings (e.g.\ the current working directory). One side-effect of this is that one must not pass in values with a reference count of zero to any of these functions. If such calls were handled, they might result in memory leaks (under some circumstances, the filesystem code may wish to retain a reference to the passed in value, and so one must not assume that after any of these calls return, the value still has a reference count of zero - it may have been incremented) or in a direct segmentation fault (or other memory access error) due to the value being freed part way through the complex value manipulation required to ensure that the path is fully normalized and absolute for filesystem determination. The practical lesson to learn from this is that .PP .CS Tcl_Obj *path = Tcl_NewStringObj(...); Tcl_FS\fIWhatever\fR(path); Tcl_DecrRefCount(path); .CE .PP is wrong, and may cause memory errors. The \fIpath\fR must have its reference count incremented before passing it in, or decrementing it. For this reason, values with a reference count of zero are considered not to be valid filesystem paths and calling any Tcl_FS API function with such a value will result in no action being taken. .SS "FS API FUNCTIONS" \fBTcl_FSCopyFile\fR attempts to copy the file given by \fIsrcPathPtr\fR to the path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's .QW "copy file" function is called (if it is non-NULL). |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link of one of the types passed in in the \fIlinkAction\fR flag. This flag is an ORed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. Where a choice exists (i.e.\ more than one flag is passed in), the Tcl convention is to prefer symbolic links. When a link is successfully created, the return value should be \fItoPtr\fR (which is therefore already owned by the caller). If unsuccessful, NULL is returned. |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 | .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP If the result is \fBTCL_OK\fR, then a value was placed in \fIobjPtrRef\fR, which will only be temporarily valid (unless \fBTcl_IncrRefCount\fR is called). .PP \fBTcl_FSFileAttrsSet\fR implements write access for the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP \fBTcl_FSFileAttrStrings\fR implements part of the hookable \fBfile attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The called procedure may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it retains a reference count to the value. .PP \fBTcl_FSAccess\fR checks whether the process would be allowed to read, write or test for existence of the file (or other filesystem object) whose name is \fIpathname\fR. If \fIpathname\fR is a symbolic link on Unix, then permissions of the file referred by this symbolic link are tested. .PP |
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length 1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path | | | | | | | | | | | | | | | | | > | | | | | | | | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length 1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path value given by considering the first \fIelements\fR elements as valid path segments (each path segment may be a complete path, a partial path or just a single possible directory or file name). If any path segment is actually an absolute path, then all prior path segments are discarded. If \fIelements\fR is less than 0, we use the entire list. .PP It is possible that the returned value is actually an element of the given list, so the caller should be careful to increment the reference count of the result before freeing the list. .PP The returned value, typically with a reference count of zero (but it could be shared under some conditions), contains the joined path. The caller must add a reference count to the value before using it. In particular, the returned value could be an element of the given list, so freeing the list might free the value prematurely if no reference count has been taken. If the number of elements is zero, then the returned value will be an empty-string Tcl_Obj. .PP \fBTcl_FSSplitPath\fR takes the given Tcl_Obj, which should be a valid path, and returns a Tcl list value containing each segment of that path as an element. It returns a list value with a reference count of zero. If the passed in \fIlenPtr\fR is non-NULL, the variable it points to will be updated to contain the number of elements in the returned list. .PP \fBTcl_FSEqualPaths\fR tests whether the two paths given represent the same filesystem object. It returns 1 if the paths are equal, and 0 if they are different. If either path is NULL, 0 is always returned. .PP \fBTcl_FSGetNormalizedPath\fR this important function attempts to extract from the given Tcl_Obj a unique normalized path representation, whose string value can be used as a unique identifier for the file. .PP It returns the normalized path value, owned by Tcl, or NULL if the path was invalid or could otherwise not be successfully converted. Extraction of absolute, normalized paths is very efficient (because the filesystem operates on these representations internally), although the result when the filesystem contains numerous symbolic links may not be the most user-friendly version of a path. The return value is owned by Tcl and has a lifetime equivalent to that of the \fIpathPtr\fR passed in (unless that is a relative path, in which case the normalized path value may be freed any time the cwd changes) - the caller can of course increment the reference count if it wishes to maintain a copy for longer. .PP \fBTcl_FSJoinToPath\fR takes the given value, which should usually be a valid path or NULL, and joins onto it the array of paths segments given. .PP Returns a value, typically with reference count of zero (but it could be shared under some conditions), containing the joined path. The caller must add a reference count to the value before using it. If any of the values passed into this function (\fIpathPtr\fR or \fIpath\fR elements) have a reference count of zero, they will be freed when this function returns. .PP \fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid Tcl path type, taking account of the fact that the cwd may have changed even if this value is already supposedly of the correct type. The filename may begin with .QW ~ (to indicate current user's home directory) or .QW ~<user> (to indicate any user's home directory). .PP If the conversion succeeds (i.e.\ the value is a valid path in one of the current filesystems), then \fBTCL_OK\fR is returned. Otherwise \fBTCL_ERROR\fR is returned, and an error message may be left in the interpreter. .PP \fBTcl_FSGetInternalRep\fR extracts the internal representation of a given path value, in the given filesystem. If the path value belongs to a different filesystem, we return NULL. If the internal representation is currently NULL, we attempt to generate it, by calling the filesystem's \fBTcl_FSCreateInternalRepProc\fR. .PP Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP \fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path from the given Tcl_Obj. .PP If the translation succeeds (i.e.\ the value is a valid path), then it is returned. Otherwise NULL will be returned, and an error message may be left in the interpreter. A .QW translated path is one which contains no .QW ~ or .QW ~user sequences (these have been expanded to their current representation in the filesystem). The value returned is owned by the caller, which must store it or call \fBTcl_DecrRefCount\fR to ensure memory is freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g.\ \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an efficient way of creating the appropriate path value type. .PP The resulting value is a pure .QW path value, which will only receive a UTF-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix native filesystems, so that they can easily retrieve the native (char* or TCHAR*) representation of a path. This function is a convenience wrapper around \fBTcl_FSGetInternalRep\fR. It may be desirable in the future to have non-string-based native representations (for example, |
| ︙ | ︙ | |||
769 770 771 772 773 774 775 | or .QW prowrap , perhaps), and the second is the particular type of the given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP | | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 | or .QW prowrap , perhaps), and the second is the particular type of the given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP A valid list value is returned, unless the path value is not recognized, when NULL will be returned. .PP \fBTcl_FSGetFileSystemForPath\fR returns a pointer to the \fBTcl_Filesystem\fR which accepts this path as valid. .PP If no filesystem will accept the path, NULL is returned. .PP |
| ︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 | changes in a future Tcl release. .SS VERSION .PP The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR. .SS PATHINFILESYSTEMPROC .PP The \fIpathInFilesystemProc\fR field contains the address of a function | | | | | | | | | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
changes in a future Tcl release.
.SS VERSION
.PP
The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR.
.SS PATHINFILESYSTEMPROC
.PP
The \fIpathInFilesystemProc\fR field contains the address of a function
which is called to determine whether a given path value belongs to this
filesystem or not. Tcl will only call the rest of the filesystem
functions with a path for which this function has returned \fBTCL_OK\fR.
If the path does not belong, -1 should be returned (the behavior of Tcl
for any other return value is not defined). If \fBTCL_OK\fR is returned,
then the optional \fIclientDataPtr\fR output parameter can be used to
return an internal (filesystem specific) representation of the path,
which will be cached inside the path value, and may be retrieved
efficiently by the other filesystem functions. Tcl will simultaneously
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
ClientData *\fIclientDataPtr\fR);
.CE
.SS DUPINTERNALREPPROC
.PP
This function makes a copy of a path's internal representation, and is
called when Tcl needs to duplicate a path value. If NULL, Tcl will
simply not copy the internal representation, which may then need to be
regenerated later.
.PP
.CS
typedef ClientData \fBTcl_FSDupInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS FREEINTERNALREPPROC
Free the internal representation. This must be implemented if internal
representations need freeing (i.e.\ if some memory is allocated when an
internal representation is generated), but may otherwise be NULL.
.PP
.CS
typedef void \fBTcl_FSFreeInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS INTERNALTONORMALIZEDPROC
.PP
Function to convert internal representation to a normalized path. Only
required if the filesystem creates pure path values with no string/path
representation. The return value is a Tcl value whose string
representation is the normalized path.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR(
ClientData \fIclientData\fR);
.CE
.SS CREATEINTERNALREPPROC
.PP
Function to take a path value, and calculate an internal
representation for it, and store that native representation in the
value. May be NULL if paths have no internal representation, or if
the \fITcl_FSPathInFilesystemProc\fR for this filesystem always
immediately creates an internal representation for paths it accepts.
.PP
.CS
typedef ClientData \fBTcl_FSCreateInternalRepProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS NORMALIZEPATHPROC
.PP
Function to normalize a path. Should be implemented for all
filesystems which can have multiple string representations for the same
path value. In Tcl, every
.QW path
must have a single unique
.QW normalized
string representation. Depending on the filesystem,
there may be more than one unnormalized string representation which
refers to that path (e.g.\ a relative path, a path with different
character case if the filesystem is case insensitive, a path contain a
reference to a home directory such as
.QW ~ ,
a path containing symbolic
links, etc). If the very last component in the path is a symbolic
link, it should not be converted into the value it points to (but
its case or other aspects should be made unique). All other path
components should be converted from symbolic links. This one
exception is required to agree with Tcl's semantics with \fBfile
delete\fR, \fBfile rename\fR, \fBfile copy\fR operating on symbolic links.
This function may be called with \fInextCheckpoint\fR either
at the beginning of the path (i.e.\ zero), at the end of the path, or
at any intermediate file separator in the path. It will never
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 | and should be returned as the string representation of the Tcl_Obj which is returned. A typical return value might be .QW networked , .QW zip or .QW ftp . The Tcl_Obj result is owned by the filesystem and so Tcl will | | | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
and should be returned as the string representation of the Tcl_Obj
which is returned. A typical return value might be
.QW networked ,
.QW zip
or
.QW ftp .
The Tcl_Obj result is owned by the filesystem and so Tcl will
increment the reference count of that value if it wishes to retain a reference
to it.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSFilesystemPathTypeProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS FILESYSTEMSEPARATORPROC
.PP
Function to return the separator character(s) for this filesystem.
This need only be implemented if the filesystem wishes to use a
different separator than the standard string
.QW / .
Amongst other
uses, it is returned by the \fBfile separator\fR command. The
return value should be a value with reference count of zero.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSFilesystemSeparatorProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS STATPROC
.PP
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 | documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be | | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 | documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be added to the \fIresultPtr\fR value given (which can be assumed to be a valid unshared Tcl list). The matches added to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR (this usually means they will be absolute path specifications). Note that if no matches are found, that simply leads to an empty result; errors are only signaled for actual file or filesystem problems which may occur during the matching process. .PP |
| ︙ | ︙ | |||
1322 1323 1324 1325 1326 1327 1328 | .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller (and should therefore have its ref count incremented before being returned). Any callers | | | | | | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 | .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller (and should therefore have its ref count incremented before being returned). Any callers should call \fBTcl_DecrRefCount\fR on this result when it is no longer needed. If \fItoPtr\fR is not NULL, the function should attempt to create a link. The result in this case should be \fItoPtr\fR if the link was successful and NULL otherwise. In this case the result is not owned by the caller (i.e.\ no reference count manipulations on either end are needed). See the documentation for \fBTcl_FSLink\fR for the correct interpretation of the \fIlinkAction\fR flags. .SS LISTVOLUMESPROC .PP 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, so that they can be returned by \fBfile volumes\fR. .PP .CS typedef Tcl_Obj *\fBTcl_FSListVolumesProc\fR(void); .CE .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a .QW "master list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then they simply increment the reference count of their master list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC .PP Function to list all attribute strings which are valid for this |
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it returns a value with a reference count of at least one. .SS FILEATTRSGETPROC .PP Function to process a \fBTcl_FSFileAttrsGet\fR call, used by \fBfile attributes\fR. .PP .CS |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/GetIndex.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 |
msg, flags, indexPtr\fR)
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
| | > > > > > > | | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
msg, flags, indexPtr\fR)
.SH ARGUMENTS
.AS "const char" *structTablePtr in/out
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this value is used to search through \fItablePtr\fR.
The internal representation is modified to hold the index of the matching
table entry.
.AP "const char *const" *tablePtr in
An array of null-terminated strings. The end of the array is marked
by a NULL string pointer.
Note that references to the \fItablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array.
.AP "const void" *structTablePtr in
An array of arbitrary type, typically some \fBstruct\fR type.
The first member of the structure must be a null-terminated string.
The size of the structure is given by \fIoffset\fR.
Note that references to the \fIstructTablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array of structures.
.AP int offset in
The offset to add to structTablePtr to get to the next entry.
The end of the array is marked by a NULL string pointer.
.AP "const char" *msg in
Null-terminated string describing what is being looked up, such as
\fBoption\fR. This string is included in error messages.
.AP int flags in
OR-ed combination of bits providing additional information for
operation. The only bit that is currently defined is \fBTCL_EXACT\fR.
.AP int *indexPtr out
The index of the string in \fItablePtr\fR that matches the value of
\fIobjPtr\fR is returned here.
.BE
.SH DESCRIPTION
.PP
These procedures provide an efficient way for looking up keywords,
switch names, option names, and similar things where the literal value of
a Tcl value must be chosen from a predefined set.
\fBTcl_GetIndexFromObj\fR compares \fIobjPtr\fR against each of
the strings in \fItablePtr\fR to find a match. A match occurs if
\fIobjPtr\fR's string value is identical to one of the strings in
\fItablePtr\fR, or if it is a non-empty unique abbreviation
for exactly one of the strings in \fItablePtr\fR and the
\fBTCL_EXACT\fR flag was not specified; in either case
the index of the matching entry is stored at \fI*indexPtr\fR
and \fBTCL_OK\fR is returned.
|
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS | | | 97 98 99 100 101 102 103 104 | array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" prefix(n), Tcl_WrongNumArgs(3) .SH KEYWORDS index, option, value, table lookup |
Changes to pkgs/msgcat/doc/Hash.3.
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
.PP
.CS
typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
.PP
| | | | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
.PP
.CS
typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
.PP
If this is NULL then \fBTcl_Alloc\fR is used to allocate enough space for a
Tcl_HashEntry, the key pointer is assigned to key.oneWordValue and the
clientData is set to NULL. String keys and array keys use this function to
allocate enough space for the entry and the key in one block, rather than
doing it in two blocks. This saves space for a pointer to the key from the
entry and another memory allocation. Tcl_Obj* keys use this function to
allocate enough space for an entry and increment the reference count on the
value.
.PP
The \fIfreeEntryProc\fR member contains the address of a function called to
free space for an entry.
.PP
.CS
typedef void \fBTcl_FreeHashEntryProc\fR(
Tcl_HashEntry *\fIhPtr\fR);
.CE
.PP
If this is NULL then \fBTcl_Free\fR is used to free the space for the entry.
Tcl_Obj* keys use this function to decrement the reference count on the
value.
.SH KEYWORDS
hash table, key, lookup, search, value
|
Changes to pkgs/msgcat/doc/InitStubs.3.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard | | | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the library name is \fItclstub86.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for more information. .SH DESCRIPTION \fBTcl_InitStubs\fR attempts to initialize the stub table pointers |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/IntObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .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 .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in | | | | | | | | | | | | | | > | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out .AP int intValue in Integer value used to initialize or set a Tcl value. .AP long longValue in Long integer value used to initialize or set a Tcl value. .AP Tcl_WideInt wideValue in Wide integer value used to initialize or set a Tcl value. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR, this points to the value in which to store an integral value. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR, this refers to the value from which to retrieve an integral value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when integral value retrieval fails. .AP int *intPtr out Points to place to store the integer value retrieved from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out Points to a multi-precision integer structure declared by the LibTomMath library. .AP double doubleValue in Double value from which the integer part is determined and used to initialize a multi-precision integer value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl values that hold integral values. .PP The different routines exist to accommodate different integral types in C with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types 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, \fBint64\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new Tcl value initialized to the integral value of the argument. The returned Tcl value is unshared. .PP The \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR routines each set the value of an existing Tcl value pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an unshared Tcl value. Any attempt to set the value of a shared Tcl value 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_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral value of the appropriate type 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 integral value, or if the value exceeds the range of the target type. 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. Unlike the other functions, \fBTcl_TakeBignumFromObj\fR may set the content of the Tcl value \fIobjPtr\fR to an empty string in the process of retrieving the multiple-precision integer value. .PP The choice between \fBTcl_GetBignumFromObj\fR and \fBTcl_TakeBignumFromObj\fR is governed by how the caller will continue to use \fIobjPtr\fR. If after the \fBmp_int\fR value is retrieved from \fIobjPtr\fR, the caller will make no more use of \fIobjPtr\fR, then using \fBTcl_TakeBignumFromObj\fR permits Tcl to detect when an unshared \fIobjPtr\fR permits the value to be moved instead of copied, which should be more efficient. If anything later in the caller requires \fIobjPtr\fR to continue to hold the same value, then \fBTcl_GetBignumFromObj\fR must be chosen. .PP The \fBTcl_InitBignumFromDouble\fR routine is a utility procedure that extracts the integer part of \fIdoubleValue\fR and stores that integer value in the \fBmp_int\fR value \fIbigValue\fR. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS integer, integer value, integer type, internal representation, value, value type, string representation |
Changes to pkgs/msgcat/doc/ListObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl values as lists .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_ListObjAppendList\fR(\fIinterp, listPtr, elemListPtr\fR) .sp |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | \fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR) .sp int \fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *elemListPtr in/out .AP Tcl_Interp *interp in | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
\fBTcl_ListObjIndex\fR(\fIinterp, listPtr, index, objPtrPtr\fR)
.sp
int
\fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR)
.SH ARGUMENTS
.AS "Tcl_Obj *const" *elemListPtr in/out
.AP Tcl_Interp *interp in
If an error occurs while converting a value to be a list value,
an error message is left in the interpreter's result value
unless \fIinterp\fR is NULL.
.AP Tcl_Obj *listPtr in/out
Points to the list value to be manipulated.
If \fIlistPtr\fR does not already point to a list value,
an attempt will be made to convert it to one.
.AP Tcl_Obj *elemListPtr in/out
For \fBTcl_ListObjAppendList\fR, this points to a list value
containing elements to be appended onto \fIlistPtr\fR.
Each element of *\fIelemListPtr\fR will
become a new element of \fIlistPtr\fR.
If *\fIelemListPtr\fR is not NULL and
does not already point to a list value,
an attempt will be made to convert it to one.
.AP Tcl_Obj *objPtr in
For \fBTcl_ListObjAppendElement\fR,
points to the Tcl value that will be appended to \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
this points to the Tcl value that will be converted to a list value
containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR.
.AP int *objcPtr in
Points to location where \fBTcl_ListObjGetElements\fR
stores the number of element values in \fIlistPtr\fR.
.AP Tcl_Obj ***objvPtr out
A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array
of pointers to the element values of \fIlistPtr\fR.
.AP int objc in
The number of Tcl values that \fBTcl_NewListObj\fR
will insert into a new list value,
and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR.
For \fBTcl_SetListObj\fR,
the number of Tcl values to insert into \fIobjPtr\fR.
.AP "Tcl_Obj *const" objv[] in
An array of pointers to values.
\fBTcl_NewListObj\fR will insert these values into a new list value
and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR.
Each value will become a separate list element.
.AP int *intPtr out
Points to location where \fBTcl_ListObjLength\fR
stores the length of the list.
.AP int index in
Index of the list element that \fBTcl_ListObjIndex\fR
is to return.
The first element has index 0.
.AP Tcl_Obj **objPtrPtr out
Points to place where \fBTcl_ListObjIndex\fR is to store
a pointer to the resulting list element value.
.AP int first in
Index of the starting list element that \fBTcl_ListObjReplace\fR
is to replace.
The list's first element has index 0.
.AP int count in
The number of elements that \fBTcl_ListObjReplace\fR
is to replace.
.BE
.SH DESCRIPTION
.PP
Tcl list values have an internal representation that supports
the efficient indexing and appending.
The procedures described in this man page are used to
create, modify, index, and append to Tcl list values from C code.
.PP
\fBTcl_ListObjAppendList\fR and \fBTcl_ListObjAppendElement\fR
both add one or more values
to the end of the list value referenced by \fIlistPtr\fR.
\fBTcl_ListObjAppendList\fR appends each element of the list value
referenced by \fIelemListPtr\fR while
\fBTcl_ListObjAppendElement\fR appends the single value
referenced by \fIobjPtr\fR.
Both procedures will convert the value referenced by \fIlistPtr\fR
to a list value if necessary.
If an error occurs during conversion,
both procedures return \fBTCL_ERROR\fR and leave an error message
in the interpreter's result value if \fIinterp\fR is not NULL.
Similarly, if \fIelemListPtr\fR does not already refer to a list value,
\fBTcl_ListObjAppendList\fR will attempt to convert it to one
and if an error occurs during conversion,
will return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result value
if interp is not NULL.
Both procedures invalidate any old string representation of \fIlistPtr\fR
and, if it was converted to a list value,
free any old internal representation.
Similarly, \fBTcl_ListObjAppendList\fR frees any old internal representation
of \fIelemListPtr\fR if it converts it to a list value.
After appending each element in \fIelemListPtr\fR,
\fBTcl_ListObjAppendList\fR increments the element's reference count
since \fIlistPtr\fR now also refers to it.
For the same reason, \fBTcl_ListObjAppendElement\fR
increments \fIobjPtr\fR's reference count.
If no error occurs,
the two procedures return \fBTCL_OK\fR after appending the values.
.PP
\fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR
create a new value or modify an existing value to hold
the \fIobjc\fR elements of the array referenced by \fIobjv\fR
where each element is a pointer to a Tcl value.
If \fIobjc\fR is less than or equal to zero,
they return an empty value.
The new value's string representation is left invalid.
The two procedures increment the reference counts
of the elements in \fIobjc\fR since the list value now refers to them.
The new list value returned by \fBTcl_NewListObj\fR
has reference count zero.
.PP
\fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of
the elements in a list value. It returns the count by storing it in the
address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing
it in the address \fIobjvPtr\fR.
The memory pointed to is managed by Tcl and should not be freed or written
to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR
and NULL at \fIobjvPtr\fR.
If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR
will attempt to convert it to one; if the conversion fails, it returns
\fBTCL_ERROR\fR and leaves an error message in the interpreter's result
value if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer.
.PP
\fBTcl_ListObjLength\fR returns the number of elements in the list value
referenced by \fIlistPtr\fR.
It returns this count by storing an integer in the address \fIintPtr\fR.
If the value is not already a list value,
\fBTcl_ListObjLength\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise it returns \fBTCL_OK\fR after storing the list's length.
.PP
The procedure \fBTcl_ListObjIndex\fR returns a pointer to the value
at element \fIindex\fR in the list referenced by \fIlistPtr\fR.
It returns this value by storing a pointer to it
in the address \fIobjPtrPtr\fR.
If \fIlistPtr\fR does not already refer to a list value,
\fBTcl_ListObjIndex\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
If the index is out of range,
that is, \fIindex\fR is negative or
greater than or equal to the number of elements in the list,
\fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR
and returns \fBTCL_OK\fR.
Otherwise it returns \fBTCL_OK\fR after storing the element's
value pointer.
The reference count for the list element is not incremented;
the caller must do that if it needs to retain a pointer to the element.
.PP
\fBTcl_ListObjReplace\fR replaces zero or more elements
of the list referenced by \fIlistPtr\fR
with the \fIobjc\fR values in the array referenced by \fIobjv\fR.
If \fIlistPtr\fR does not point to a list value,
\fBTcl_ListObjReplace\fR will attempt to convert it to one;
if the conversion fails, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result value
if \fIinterp\fR is not NULL.
Otherwise, it returns \fBTCL_OK\fR after replacing the values.
If \fIobjv\fR is NULL, no new elements are added.
If the argument \fIfirst\fR is zero or negative,
it refers to the first element.
If \fIfirst\fR is greater than or equal to the
number of elements in the list, then no elements are deleted;
the new elements are appended to the list.
\fIcount\fR gives the number of elements to replace.
If \fIcount\fR is zero or negative then no elements are deleted;
the new elements are simply inserted before the one
designated by \fIfirst\fR.
\fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's
old string representation.
The reference counts of any elements inserted from \fIobjv\fR
are incremented since the resulting list now refers to them.
Similarly, the reference counts for any replaced values are decremented.
.PP
Because \fBTcl_ListObjReplace\fR combines
both element insertion and deletion,
it can be used to implement a number of list operations.
For example, the following code inserts the \fIobjc\fR values
referenced by the array of value pointers \fIobjv\fR
just before the element \fIindex\fR of the list referenced by \fIlistPtr\fR:
.PP
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, index, 0,
objc, objv);
.CE
.PP
Similarly, the following code appends the \fIobjc\fR values
referenced by the array \fIobjv\fR
to the end of the list \fIlistPtr\fR:
.PP
.CS
result = \fBTcl_ListObjLength\fR(interp, listPtr, &length);
if (result == TCL_OK) {
result = \fBTcl_ListObjReplace\fR(interp, listPtr, length, 0,
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
| | > | 243 244 245 246 247 248 249 250 251 |
.CS
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
append, index, insert, internal representation, length, list, list value,
list type, value, value type, replace, string representation
|
Changes to pkgs/msgcat/doc/Load.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | The name of the file to load. If it is a single name, the library search path of the current environment will be used to resolve it. .AP "const char *const" symbols[] in Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in | | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | The name of the file to load. If it is a single name, the library search path of the current environment will be used to resolve it. .AP "const char *const" symbols[] in Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in The value should normally be 0, but \fITCL_LOAD_GLOBAL\fR or \fITCL_LOAD_LAZY\fR or a combination of those two is allowed as well. .AP void *procPtrs out Points to an array that will hold the addresses of the functions described in the \fIsymbols\fR argument. Should be NULL if no symbols are to be resolved. .AP Tcl_LoadHandle *loadHandlePtr out Points to a variable that will hold the handle to the abstract token describing the library that has been loaded. .AP Tcl_LoadHandle loadHandle in |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/NRE.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | .AP Tcl_CmdDeleteProc *deleteProc in/out Procedure to call before \fIcmdName\fR is deleted from the interpreter. This procedure allows for command-specific cleanup. If \fIdeleteProc\fR is \fBNULL\fR, then no procedure is called before the command is deleted. .AP int objc in Count of parameters provided to the implementation of a command. .AP Tcl_Obj **objv in | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .AP Tcl_CmdDeleteProc *deleteProc in/out Procedure to call before \fIcmdName\fR is deleted from the interpreter. This procedure allows for command-specific cleanup. If \fIdeleteProc\fR is \fBNULL\fR, then no procedure is called before the command is deleted. .AP int objc in Count of parameters provided to the implementation of a command. .AP Tcl_Obj **objv in Pointer to an array of Tcl values. Each value holds the value of a single word in the command to execute. .AP Tcl_Obj *objPtr in Pointer to a Tcl_Obj whose value is a script or expression to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported. .\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and |
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | invoke a single Tcl command whose words have already been separated and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the words of the command to be evaluated when execution reaches the trampoline. .PP \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose resolution is already known. The \fIcmd\fR parameter gives a | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | invoke a single Tcl command whose words have already been separated and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the words of the command to be evaluated when execution reaches the trampoline. .PP \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose resolution is already known. The \fIcmd\fR parameter gives a \fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or \fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in the trampoline; this command must match the word in \fIobjv[0]\fR. The remaining arguments are as for \fBTcl_NREvalObj\fR. .PP \fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR all accept a \fIflags\fR parameter, which is an OR-ed-together set of bits to control evaluation. At the present time, the only supported flag |
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
| | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
* passed to \fBTcl_NRAddCallback\fR */
\fI... postprocessing ...\fR
return result;
}
.CE
.PP
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
| | | 319 320 321 322 323 324 325 326 327 328 |
\fBTcl_NRCreateCommand\fR(interp, "theCommand",
\fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
TheCmdDeleteProc);
.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
stackless, nonrecursive, execute, command, global, value, result, script
.SH COPYRIGHT
Copyright (c) 2008 by Kevin B. Kenny
|
Changes to pkgs/msgcat/doc/Namespace.3.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out A reference to an unshared value to which the function output will be written. .AP "const char" *pattern in The glob-style pattern (see \fBTcl_StringMatch\fR) that describes the commands to be imported or exported. .AP int resetListFirst in Whether the list of export patterns should be reset before adding the current pattern to it. |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/Object.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewObj\fR() .sp |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp \fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in | | | > | | | | | | | | | | | | | | | | | | | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
int
\fBTcl_IsShared\fR(\fIobjPtr\fR)
.sp
\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)
.SH ARGUMENTS
.AS Tcl_Obj *objPtr
.AP Tcl_Obj *objPtr in
Points to a value;
must have been the result of a previous call to \fBTcl_NewObj\fR.
.BE
.SH INTRODUCTION
.PP
This man page presents an overview of Tcl values (called \fBTcl_Obj\fRs for
historical reasons) and how they are used.
It also describes generic procedures for managing Tcl values.
These procedures are used to create and copy values,
and increment and decrement the count of references (pointers) to values.
The procedures are used in conjunction with ones
that operate on specific types of values such as
\fBTcl_GetIntFromObj\fR and \fBTcl_ListObjAppendElement\fR.
The individual procedures are described along with the data structures
they manipulate.
.PP
Tcl's \fIdual-ported\fR values provide a general-purpose mechanism
for storing and exchanging Tcl values.
They largely replace the use of strings in Tcl.
For example, they are used to store variable values,
command arguments, command results, and scripts.
Tcl values behave like strings but also hold an internal representation
that can be manipulated more efficiently.
For example, a Tcl list is now represented as a value
that holds the list's string representation
as well as an array of pointers to the values for each list element.
Dual-ported values avoid most runtime type conversions.
They also improve the speed of many operations
since an appropriate representation is immediately available.
The compiler itself uses Tcl values to
cache the instruction bytecodes resulting from compiling scripts.
.PP
The two representations are a cache of each other and are computed lazily.
That is, each representation is only computed when necessary,
it is computed from the other representation,
and, once computed, it is saved.
In addition, a change in one representation invalidates the other one.
As an example, a Tcl program doing integer calculations can
operate directly on a variable's internal machine integer
representation without having to constantly convert
between integers and strings.
Only when it needs a string representing the variable's value,
say to print it,
will the program regenerate the string representation from the integer.
Although values contain an internal representation,
their semantics are defined in terms of strings:
an up-to-date string can always be obtained,
and any change to the value will be reflected in that string
when the value's string representation is fetched.
Because of this representation invalidation and regeneration,
it is dangerous for extension writers to access
\fBTcl_Obj\fR fields directly.
It is better to access Tcl_Obj information using
procedures like \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR.
.PP
Values are allocated on the heap
and are referenced using a pointer to their \fBTcl_Obj\fR structure.
Values are shared as much as possible.
This significantly reduces storage requirements
because some values such as long lists are very large.
Also, most Tcl values are only read and never modified.
This is especially true for procedure arguments,
which can be shared between the caller and the called procedure.
Assignment and argument binding is done by
simply assigning a pointer to the value.
Reference counting is used to determine when it is safe to
reclaim a value's storage.
.PP
Tcl values are typed.
A value's internal representation is controlled by its type.
Several types are predefined in the Tcl core
including integer, double, list, and bytecode.
Extension writers can extend the set of types
by defining their own \fBTcl_ObjType\fR structs.
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
int \fIrefCount\fR;
char *\fIbytes\fR;
int \fIlength\fR;
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
unsigned long \fIvalue\fR;
} \fIptrAndLongRep\fR;
} \fIinternalRep\fR;
} \fBTcl_Obj\fR;
.CE
.PP
The \fIbytes\fR and the \fIlength\fR members together hold
a value's UTF-8 string representation,
which is a \fIcounted string\fR not containing null bytes (UTF-8 null
characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
this allows string representations
to be treated as conventional null-terminated C strings.
C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
a value's string representation.
If \fIbytes\fR is NULL,
the string representation is invalid.
.PP
A value's type manages its internal representation.
The member \fItypePtr\fR points to the Tcl_ObjType structure
that describes the type.
If \fItypePtr\fR is NULL,
the internal representation is invalid.
.PP
The \fIinternalRep\fR union member holds
a value's internal representation.
This is either a (long) integer, a double-precision floating-point number,
a pointer to a value containing additional information
needed by the value's type to represent the value, a Tcl_WideInt
integer, two arbitrary pointers, or a pair made up of an unsigned long
integer and a pointer.
.PP
The \fIrefCount\fR member is used to tell when it is safe to free
a value's storage.
It holds the count of active references to the value.
Maintaining the correct reference count is a key responsibility
of extension writers.
Reference counting is discussed below
in the section \fBSTORAGE MANAGEMENT OF VALUES\fR.
.PP
Although extension writers can directly access
the members of a Tcl_Obj structure,
it is much better to use the appropriate procedures and macros.
For example, extension writers should never
read or update \fIrefCount\fR directly;
they should use macros such as
\fBTcl_IncrRefCount\fR and \fBTcl_IsShared\fR instead.
.PP
A key property of Tcl values is that they hold two representations.
A value typically starts out containing only a string representation:
it is untyped and has a NULL \fItypePtr\fR.
A value containing an empty string or a copy of a specified string
is created using \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR respectively.
A value's string value is gotten with
\fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR
and changed with \fBTcl_SetStringObj\fR.
If the value is later passed to a procedure like \fBTcl_GetIntFromObj\fR
that requires a specific internal representation,
the procedure will create one and set the value's \fItypePtr\fR.
The internal representation is computed from the string representation.
A value's two representations are duals of each other:
changes made to one are reflected in the other.
For example, \fBTcl_ListObjReplace\fR will modify a value's
internal representation and the next call to \fBTcl_GetStringFromObj\fR
or \fBTcl_GetString\fR will reflect that change.
.PP
Representations are recomputed lazily for efficiency.
A change to one representation made by a procedure
such as \fBTcl_ListObjReplace\fR is not reflected immediately
in the other representation.
Instead, the other representation is marked invalid
so that it is only regenerated if it is needed later.
Most C programmers never have to be concerned with how this is done
and simply use procedures such as \fBTcl_GetBooleanFromObj\fR or
\fBTcl_ListObjIndex\fR.
Programmers that implement their own value types
must check for invalid representations
and mark representations invalid when necessary.
The procedure \fBTcl_InvalidateStringRep\fR is used
to mark a value's string representation invalid and to
free any storage associated with the old string representation.
.PP
Values usually remain one type over their life,
but occasionally a value must be converted from one type to another.
For example, a C program might build up a string in a value
with repeated calls to \fBTcl_AppendToObj\fR,
and then call \fBTcl_ListObjIndex\fR to extract a list element from
the value.
The same value holding the same string value
can have several different internal representations
at different times.
Extension writers can also force a value to be converted from one type
to another using the \fBTcl_ConvertToType\fR procedure.
Only programmers that create new value types need to be concerned
about how this is done.
A procedure defined as part of the value type's implementation
creates a new internal representation for a value
and changes its \fItypePtr\fR.
See the man page for \fBTcl_RegisterObjType\fR
to see how to create a new value type.
.SH "EXAMPLE OF THE LIFETIME OF A VALUE"
.PP
As an example of the lifetime of a value,
consider the following sequence of commands:
.PP
.CS
\fBset x 123\fR
.CE
.PP
This assigns to \fIx\fR an untyped value whose
\fIbytes\fR member points to \fB123\fR and \fIlength\fR member contains 3.
The value's \fItypePtr\fR member is NULL.
.PP
.CS
\fBputs "x is $x"\fR
.CE
.PP
\fIx\fR's string representation is valid (since \fIbytes\fR is non-NULL)
and is fetched for the command.
.PP
.CS
\fBincr x\fR
.CE
.PP
The \fBincr\fR command first gets an integer from \fIx\fR's value
by calling \fBTcl_GetIntFromObj\fR.
This procedure checks whether the value is already an integer value.
Since it is not, it converts the value
by setting the value's \fIinternalRep.longValue\fR member
to the integer \fB123\fR
and setting the value's \fItypePtr\fR
to point to the integer Tcl_ObjType structure.
Both representations are now valid.
\fBincr\fR increments the value's integer internal representation
then invalidates its string representation
(by calling \fBTcl_InvalidateStringRep\fR)
since the string representation
no longer corresponds to the internal representation.
.PP
.CS
\fBputs "x is now $x"\fR
.CE
.PP
The string representation of \fIx\fR's value is needed
and is recomputed.
The string representation is now \fB124\fR
and both representations are again valid.
.SH "STORAGE MANAGEMENT OF VALUES"
.PP
Tcl values are allocated on the heap and are shared as much as possible
to reduce storage requirements.
Reference counting is used to determine when a value is
no longer needed and can safely be freed.
A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR
has \fIrefCount\fR 0.
The macro \fBTcl_IncrRefCount\fR increments the reference count
when a new reference to the value is created.
The macro \fBTcl_DecrRefCount\fR decrements the count
when a reference is no longer needed and,
if the value's reference count drops to zero, frees its storage.
A value shared by different code or data structures has
\fIrefCount\fR greater than 1.
Incrementing a value's reference count ensures that
it will not be freed too early or have its value change accidentally.
.PP
As an example, the bytecode interpreter shares argument values
between calling and called Tcl procedures to avoid having to copy values.
It assigns the call's argument values to the procedure's
formal parameter variables.
In doing so, it calls \fBTcl_IncrRefCount\fR to increment
the reference count of each argument since there is now a new
reference to it from the formal parameter.
When the called procedure returns,
the interpreter calls \fBTcl_DecrRefCount\fR to decrement
each argument's reference count.
When a value's reference count drops less than or equal to zero,
\fBTcl_DecrRefCount\fR reclaims its storage.
Most command procedures do not have to be concerned about
reference counting since they use a value's value immediately
and do not retain a pointer to the value after they return.
However, if they do retain a pointer to a value in a data structure,
they must be careful to increment its reference count
since the retained pointer is a new reference.
.PP
Command procedures that directly modify values
such as those for \fBlappend\fR and \fBlinsert\fR must be careful to
copy a shared value before changing it.
They must first check whether the value is shared
by calling \fBTcl_IsShared\fR.
If the value is shared they must copy the value
by using \fBTcl_DuplicateObj\fR;
this returns a new duplicate of the original value
that has \fIrefCount\fR 0.
If the value is not shared,
the command procedure
.QW "owns"
the value and can safely modify it directly.
For example, the following code appears in the command procedure
that implements \fBlinsert\fR.
This procedure modifies the list value passed to it in \fIobjv[1]\fR
by inserting \fIobjc-3\fR new elements before \fIindex\fR.
.PP
.CS
listPtr = objv[1];
if (\fBTcl_IsShared\fR(listPtr)) {
listPtr = \fBTcl_DuplicateObj\fR(listPtr);
}
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]));
.CE
.PP
As another example, \fBincr\fR's command procedure
must check whether the variable's value is shared before
incrementing the integer in its internal representation.
If it is shared, it needs to duplicate the value
in order to avoid accidentally changing values in other data structures.
.SH "SEE ALSO"
Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3)
.SH KEYWORDS
internal representation, value, value creation, value type,
reference counting, string representation, type conversion
|
Changes to pkgs/msgcat/doc/ObjectType.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | | | | > | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl value types .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_RegisterObjType\fR(\fItypePtr\fR) .sp const Tcl_ObjType * \fBTcl_GetObjType\fR(\fItypeName\fR) .sp int \fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR) .SH ARGUMENTS .AS "const char" *typeName .AP "const Tcl_ObjType" *typePtr in Points to the structure containing information about the Tcl value type. This storage must live forever, typically by being statically allocated. .AP "const char" *typeName in The name of a Tcl value type that \fBTcl_GetObjType\fR should look up. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP Tcl_Obj *objPtr in For \fBTcl_AppendAllObjTypes\fR, this points to the value onto which it appends the name of each value type as a list element. For \fBTcl_ConvertToType\fR, this points to a value that must have been the result of a previous call to \fBTcl_NewObj\fR. .BE .SH DESCRIPTION .PP The procedures in this man page manage Tcl value types (sometimes referred to as object types or \fBTcl_ObjType\fRs for historical reasons). They are used to register new value types, look up types, and force conversions from one type to another. .PP \fBTcl_RegisterObjType\fR registers a new Tcl value type in the table of all value types that \fBTcl_GetObjType\fR can look up by name. There are other value types supported by Tcl as well, which Tcl chooses not to register. Extensions can likewise choose to register the value types they create or not. The argument \fItypePtr\fR points to a Tcl_ObjType structure that describes the new type by giving its name and by supplying pointers to four procedures that implement the type. If the type table already contains a type with the same name as in \fItypePtr\fR, it is replaced with the new type. The Tcl_ObjType structure is described in the section \fBTHE TCL_OBJTYPE STRUCTURE\fR below. .PP \fBTcl_GetObjType\fR returns a pointer to the registered Tcl_ObjType with name \fItypeName\fR. It returns NULL if no type with that name is registered. .PP \fBTcl_AppendAllObjTypes\fR appends the name of each registered value type as a list element onto the Tcl value referenced by \fIobjPtr\fR. The return value is \fBTCL_OK\fR unless there was an error converting \fIobjPtr\fR to a list value; in that case \fBTCL_ERROR\fR is returned. .PP \fBTcl_ConvertToType\fR converts a value from one type to another if possible. It creates a new internal representation for \fIobjPtr\fR appropriate for the target type \fItypePtr\fR and sets its \fItypePtr\fR member as determined by calling the \fItypePtr->setFromAnyProc\fR routine. Any internal representation for \fIobjPtr\fR's old type is freed. If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the result value for \fIinterp\fR unless \fIinterp\fR is NULL. Otherwise, it returns \fBTCL_OK\fR. Passing a NULL \fIinterp\fR allows this procedure to be used as a test whether the conversion can be done (and in fact was done). .VS 8.5 .PP In many cases, the \fItypePtr->setFromAnyProc\fR routine will set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR, but that is no longer guaranteed. The \fIsetFromAnyProc\fR is free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. .VE 8.5 .SH "THE TCL_OBJTYPE STRUCTURE" .PP Extension writers can define new value types by defining four procedures and initializing a Tcl_ObjType structure to describe the type. Extension writers may also pass a pointer to their Tcl_ObjType structure to \fBTcl_RegisterObjType\fR if they wish to permit other extensions to look up their Tcl_ObjType by name with the \fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is defined as follows: |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | .SS "THE NAME FIELD" .PP The \fIname\fR member describes the name of the type, e.g. \fBint\fR. When a type is registered, this is the name used by callers of \fBTcl_GetObjType\fR to lookup the type. For unregistered types, the \fIname\fR field is primarily of value for debugging. The remaining four members are pointers to procedures | | | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
.SS "THE NAME FIELD"
.PP
The \fIname\fR member describes the name of the type, e.g. \fBint\fR.
When a type is registered, this is the name used by callers
of \fBTcl_GetObjType\fR to lookup the type. For unregistered
types, the \fIname\fR field is primarily of value for debugging.
The remaining four members are pointers to procedures
called by the generic Tcl value code:
.SS "THE SETFROMANYPROC FIELD"
.PP
The \fIsetFromAnyProc\fR member contains the address of a function
called to create a valid internal representation
from a value's string representation.
.PP
.CS
typedef int \fBTcl_SetFromAnyProc\fR(
Tcl_Interp *\fIinterp\fR,
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
If an internal representation cannot be created from the string,
it returns \fBTCL_ERROR\fR and puts a message
describing the error in the result value for \fIinterp\fR
unless \fIinterp\fR is NULL.
If \fIsetFromAnyProc\fR is successful,
it stores the new internal representation,
sets \fIobjPtr\fR's \fItypePtr\fR member to point to
the \fBTcl_ObjType\fR struct corresponding to the new
internal representation, and returns \fBTCL_OK\fR.
Before setting the new internal representation,
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will lead to a panic, so to avoid this possibility, the type should \fInot\fR be registered. .SS "THE UPDATESTRINGPROC FIELD" .PP The \fIupdateStringProc\fR member contains the address of a function called to create a valid string representation | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will
lead to a panic, so to avoid this possibility, the type
should \fInot\fR be registered.
.SS "THE UPDATESTRINGPROC FIELD"
.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
from a value's internal representation.
.PP
.CS
typedef void \fBTcl_UpdateStringProc\fR(
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
\fIobjPtr\fR's \fIbytes\fR member is always NULL when it is called.
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | making use of the internal representation are written so that the string representation is never invalidated. Failure to meet this obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR or other similar routines ask for the string representation. .SS "THE DUPINTREPPROC FIELD" .PP The \fIdupIntRepProc\fR member contains the address of a function | | | | | | | | | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
making use of the internal representation are written so that the
string representation is never invalidated. Failure to meet this
obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR
or other similar routines ask for the string representation.
.SS "THE DUPINTREPPROC FIELD"
.PP
The \fIdupIntRepProc\fR member contains the address of a function
called to copy an internal representation from one value to another.
.PP
.CS
typedef void \fBTcl_DupInternalRepProc\fR(
Tcl_Obj *\fIsrcPtr\fR,
Tcl_Obj *\fIdupPtr\fR);
.CE
.PP
\fIdupPtr\fR's internal representation is made a copy of \fIsrcPtr\fR's
internal representation.
Before the call,
\fIsrcPtr\fR's internal representation is valid and \fIdupPtr\fR's is not.
\fIsrcPtr\fR's value type determines what
copying its internal representation means.
.PP
For example, the \fIdupIntRepProc\fR for the Tcl integer type
simply copies an integer.
The built-in list type's \fIdupIntRepProc\fR uses a far more
sophisticated scheme to continue sharing storage as much as it
reasonably can.
.SS "THE FREEINTREPPROC FIELD"
.PP
The \fIfreeIntRepProc\fR member contains the address of a function
that is called when a value is freed.
.PP
.CS
typedef void \fBTcl_FreeInternalRepProc\fR(
Tcl_Obj *\fIobjPtr\fR);
.CE
.PP
The \fIfreeIntRepProc\fR function can deallocate the storage
for the value's internal representation
and do other type-specific processing necessary when a value is freed.
.PP
For example, the list type's \fIfreeIntRepProc\fR respects
the storage sharing scheme established by the \fIdupIntRepProc\fR
so that it only frees storage when the last value sharing it
is being freed.
.PP
The \fIfreeIntRepProc\fR member can be set to NULL
to indicate that the internal representation does not require freeing.
The \fIfreeIntRepProc\fR implementation must not access the
\fIbytes\fR member of the value, since Tcl makes its own internal
uses of that field during value deletion. The defined tasks for
the \fIfreeIntRepProc\fR have no need to consult the \fIbytes\fR
member.
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3)
.SH KEYWORDS
internal representation, value, value type, string representation, type conversion
|
Changes to pkgs/msgcat/doc/OpenFileChnl.3.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out | | | | | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. .AP int charsToRead in The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. .AP int bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl value in which to store the line read from the channel. The line read will be appended to the current value of the value. .AP Tcl_DString *lineRead in/out A pointer to a Tcl dynamic string in which to store the line read from the channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. .AP int inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or beginning of the channel buffer. .AP Tcl_Obj *writeObjPtr in A pointer to a Tcl value whose contents will be output to the channel. .AP "const char" *charBuf in A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. .AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. |
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. As of Tcl 8.4, the value-based API \fBTcl_FSOpenFileChannel\fR should be used in preference to \fBTcl_OpenFileChannel\fR wherever possible. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. 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. |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a list value. \fBTcl_GetChannelNamesEx\fR will filter these names according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it will not do any filtering. The return value is \fBTCL_OK\fR if no errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR, and the error message is left in the interpreter's result. .SH TCL_REGISTERCHANNEL .PP \fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible |
| ︙ | ︙ | |||
431 432 433 434 435 436 437 | end-of-line recognition mode. End-of-line recognition and the various platform-specific modes are described in the manual entry for the Tcl \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a | | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 | end-of-line recognition mode. End-of-line recognition and the various platform-specific modes are described in the manual entry for the Tcl \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a byte-array value. The string representation of this value will only be constructed if it is needed (e.g., because of a call to \fBTcl_GetStringFromObj\fR). In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it does not do |
| ︙ | ︙ | |||
480 481 482 483 484 485 486 | no data was available or the data that was available did not contain an end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | no data was available or the data that was available did not contain an end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by \fIlineRead\fR rather than a Tcl value. .SH "TCL_UNGETS" .PP \fBTcl_Ungets\fR is used to add data to the input queue of a channel, at either the head or tail of the queue. The pointer \fIinput\fR points to the data that is to be added. The length of the input to add is given by \fIinputLen\fR. A non-zero value of \fIaddAtEnd\fR indicates that the data is to be added at the end of queue; otherwise it will be added at the |
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it accepts a Tcl value whose contents will be output to the channel. The UTF-8 characters in \fIwriteObjPtr\fR's string representation are converted to the channel's encoding and queued for output to \fIchannel\fR. As a performance optimization, when writing to a channel with the encoding \fBbinary\fR, UTF-8 characters are not converted as they are written. Instead, the bytes in \fIwriteObjPtr\fR's internal representation as a byte-array value are written to the channel. The byte-array representation of the value will be constructed if it is needed. In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it does not do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/ParseArgs.3.
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
| | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
\fIobjPtr\fR is the value that represents the following argument or NULL if
there are no following arguments at all, and the \fIdstPtr\fR argument to the
\fBTcl_ArgvFuncProc\fR is the location to write the parsed value to.
.RE
.TP
\fBTCL_ARGV_GENFUNC\fR
.
This argument takes zero or more following arguments; the handler callback
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. .TP \fBTCL_ARGV_STRING\fR . This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR fields are ignored. .TP \fBTCL_ARGV_STRING\fR . This argument takes a following string value argument. A pointer to the string will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked to the lifetime of the string representation of the argument value that it came from, and so should be copied if it needs to be retained. The \fIsrcPtr\fR and \fIclientData\fR fields are ignored. .SH "SEE ALSO" Tcl_GetIndexFromObj(3), Tcl_Main(3), Tcl_CreateObjCommand(3) .SH KEYWORDS argument, parse '\" Local Variables: '\" fill-column: 78 '\" End: |
Changes to pkgs/msgcat/doc/ParseCmd.3.
| ︙ | ︙ | |||
190 191 192 193 194 195 196 | \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. | | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. The reference count of the value returned as result has been incremented, so the caller must invoke \fBTcl_DecrRefCount\fR when it is finished with the value. If an error or other exception occurs while evaluating the tokens (such as a reference to a non-existent variable) then the return value is NULL and an error message is left in \fIinterp\fR's result. The use of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/RecEvalObj.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | int \fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in Points to a Tcl value containing a command (or sequence of commands) to execute. .AP int flags in An OR'ed combination of flag bits. \fBTCL_NO_EVAL\fR means record the command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .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) that can be retrieved using \fBTcl_GetObjResult\fR. If you do not want the command recorded on the history list then you should invoke \fBTcl_EvalObjEx\fR instead of \fBTcl_RecordAndEvalObj\fR. Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .SH "SEE ALSO" Tcl_EvalObjEx, Tcl_GetObjResult .SH KEYWORDS command, event, execute, history, interpreter, value, record |
Changes to pkgs/msgcat/doc/RecordEval.3.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the | | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the value-based procedure \fBTcl_RecordAndEvalObj\fR. That value-based procedure records and optionally executes a command held in a Tcl value instead of a string. .SH "SEE ALSO" Tcl_RecordAndEvalObj .SH KEYWORDS command, event, execute, history, interpreter, record |
Changes to pkgs/msgcat/doc/RegExp.3.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | .fi .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out | | | | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | .fi .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out Refers to the value from which to get the text to search. The internal representation of the value may be converted to a form that can be efficiently searched. .AP Tcl_Obj *patObj in/out Refers to the value from which to get a regular expression. The compiled regular expression is cached in the value. .AP char *text in Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it operates on the Tcl values \fItextObj\fR and \fIpatObj\fR instead of UTF strings. \fBTcl_RegExpMatchObj\fR is generally more efficient than \fBTcl_RegExpMatch\fR, so it is the preferred interface. .PP \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR provide lower-level access to the regular expression pattern matcher. \fBTcl_RegExpCompile\fR compiles a regular expression string into |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and | | | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and \fBTcl_RegExpGetInfo\fR are value interfaces that provide the most direct control of Henry Spencer's regular expression library. For users that need to modify compilation and execution options directly, it is recommended that you use these interfaces instead of calling the internal regexp functions. These interfaces handle the details of UTF to Unicode translations as well as providing improved performance through caching in the pattern and string values. .PP \fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular expression from the \fIpatObj\fR. If the value does not already contain a compiled regular expression it will attempt to create one from the string in the value and assign it to the internal representation of the \fIpatObj\fR. The return value of this function is of type \fBTcl_RegExp\fR. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR. If an error occurs while compiling the regular expression then \fBTcl_GetRegExpFromObj\fR returns NULL and leaves an error message in the interpreter result. The regular expression token can be used as |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/SaveResult.3.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | .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 | | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | .PP The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. .PP \fBTcl_SaveResult\fR moves the string and value results of \fIinterp\fR into the location specified by \fIstatePtr\fR. \fBTcl_SaveResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. .PP \fBTcl_RestoreResult\fR moves the string and value results from \fIstatePtr\fR back into \fIinterp\fR. Any result or error that was already in the interpreter will be cleared. The \fIstatePtr\fR is left in an uninitialized state and cannot be used until another call to \fBTcl_SaveResult\fR. .PP \fBTcl_DiscardResult\fR releases the saved interpreter state stored at \fBstatePtr\fR. The state structure is left in an |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/SetChanErr.3.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | to place arbitrary error messages in \fBbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the | | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | to place arbitrary error messages in \fBbypass areas\fR defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The POSIX error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the specified channel. The number of references to the \fBmsg\fR value goes up by one. Previously stored information will be discarded, by releasing the reference held by the channel. The channel reference must not be NULL. .PP \fBTcl_SetChannelErrorInterp\fR stores error information in the bypass area of the specified interpreter. The number of references to the \fBmsg\fR value goes up by one. Previously stored information will be discarded, by releasing the reference held by the interpreter. The interpreter reference must not be NULL. .PP \fBTcl_GetChannelError\fR places either the error message held in the bypass area of the specified channel into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the channel is now held by the caller of the function and it is its responsibility to release that reference when it is done with the value. .PP \fBTcl_GetChannelErrorInterp\fR places either the error message held in the bypass area of the specified interpreter into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the interpreter is now held by the caller of the function and it is its responsibility to release that reference when it is done with the value. .PP Which functions of a channel driver are allowed to use which bypass function is listed below, as is which functions of the public channel API may leave a messages in the bypass areas. .IP \fBTcl_DriverCloseProc\fR May use \fBTcl_SetChannelErrorInterp\fR, and only this function. .IP \fBTcl_DriverInputProc\fR |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/SetResult.3.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in Tcl value to become result for \fIinterp\fR. .AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. .AP "const char" *element in String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in |
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | information as well. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. | | | | | | | | | | | | | | | | | | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | information as well. .VE 8.6 .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. The interpreter result may be either a Tcl value or a string. For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR set the interpreter result to, respectively, a value and a string. Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR return the interpreter result as a value and as a string. The procedures always keep the string and value forms of the interpreter result consistent. For example, if \fBTcl_SetObjResult\fR is called to set the result to a value, then \fBTcl_GetStringResult\fR is called, it will return the value's string representation. .PP \fBTcl_SetObjResult\fR arranges for \fIobjPtr\fR to be the result for \fIinterp\fR, replacing any existing result. The result is left pointing to the value referenced by \fIobjPtr\fR. \fIobjPtr\fR's reference count is incremented since there is now a new reference to it from \fIinterp\fR. The reference count for any old result value is decremented and the old result value is freed if no references to it remain. .PP \fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value. The value's reference count is not incremented; if the caller needs to retain a long-term pointer to the value they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR arranges for \fIresult\fR to be the result for the current Tcl command in \fIinterp\fR, replacing any existing result. The \fIfreeProc\fR argument specifies how to manage the storage for the \fIresult\fR argument; it is discussed in the section \fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to an empty string. .PP \fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. If the result was set to a value by a \fBTcl_SetObjResult\fR call, the value form will be converted to a string and returned. If the value's string representation contains null bytes, this conversion will lose information. For this reason, programmers are encouraged to write their code to use the new value API procedures and to call \fBTcl_GetObjResult\fR instead. .PP \fBTcl_ResetResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. If the result is a value, its reference count is decremented and the result is left pointing to an unshared value representing an empty string. If the result is a dynamically allocated string, its memory is free*d and the result is left as a empty string. \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. .PP \fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. |
| ︙ | ︙ | |||
163 164 165 166 167 168 169 | .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR | | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | .VE 8.6 .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR that manipulate the result as a value can be significantly more efficient. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR argument and it appends that argument to the current result as a proper Tcl list element. |
| ︙ | ︙ | |||
248 249 250 251 252 253 254 | .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS | | | 248 249 250 251 252 253 254 255 | .CE .PP When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS append, command, element, list, value, result, return value, interpreter |
Changes to pkgs/msgcat/doc/SetVar.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in Points to a Tcl value containing the new value for the variable. .AP int flags in OR-ed combination of bits providing additional information. See below for valid values. .AP "const char" *varName in Name of variable. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array. .AP "const char" *newValue in New value for variable, specified as a null-terminated string. A copy of this value is stored in the variable. .AP Tcl_Obj *part1Ptr in Points to a Tcl value containing the variable's name. The name may include a series of \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array variable. .AP Tcl_Obj *part2Ptr in If non-NULL, points to a value containing the name of an element within an array and \fIpart1Ptr\fR must refer to an array variable. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, read, and delete Tcl variables from C code. |
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS | | | 242 243 244 245 246 247 248 249 | If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS array, get variable, interpreter, scalar, set, unset, value, variable |
Changes to pkgs/msgcat/doc/SplitPath.3.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | .AP Tcl_DString *resultPtr in/out A pointer to an initialized \fBTcl_DString\fR to which the result of \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP These procedures have been superseded by the Tcl-value-aware procedures in the \fBFileSystem\fR man page, which are more efficient. .PP These procedures may be used to disassemble and reassemble file paths in a platform independent manner: they provide C-level access to the same functionality as the \fBfile split\fR, \fBfile join\fR, and \fBfile pathtype\fR commands. .PP |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/StringObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 | .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\e700\e600\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) .AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. .AP int numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. If negative, all characters up to the first null character are used. .AP int index in The index of the Unicode character to return. .AP int first in The index of the first Unicode character in the Unicode range to be returned as a new value. .AP int last in The index of the last Unicode character in the Unicode range to be returned as a new value. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP int limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." is used. .AP "const char" *format in Format control string including % conversion specifiers. .AP int objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE .SH DESCRIPTION .PP The procedures described in this manual entry allow Tcl values to be manipulated as string values. They use the internal representation of the value to store additional information to make the string manipulations more efficient. In particular, they make a series of append operations efficient by allocating extra storage space for the string so that it does not have to be copied for each append. Also, indexing and length computations are optimized because the Unicode string representation is calculated and cached as needed. When using the \fBTcl_Append*\fR family of functions where the interpreter's result is the value being appended to, it is important to call Tcl_ResetResult first to ensure you are not unintentionally appending to existing data in the result value. .PP \fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new value or modify an existing value to hold a copy of the string given by \fIbytes\fR and \fIlength\fR. \fBTcl_NewUnicodeObj\fR and \fBTcl_SetUnicodeObj\fR create a new value or modify an existing value to hold a copy of the Unicode string given by \fIunicode\fR and \fInumChars\fR. \fBTcl_NewStringObj\fR and \fBTcl_NewUnicodeObj\fR return a pointer to a newly created value with reference count zero. All four procedures set the value to hold a copy of the specified string. \fBTcl_SetStringObj\fR and \fBTcl_SetUnicodeObj\fR free any old string representation as well as any old internal representation of the value. .PP \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return a value's string representation. This is given by the returned byte pointer and (for \fBTcl_GetStringFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. If the value's UTF string representation is invalid (its byte pointer is NULL), the string representation is regenerated from the value's internal representation. The storage referenced by the returned byte pointer is owned by the value manager. It is passed back as a writable pointer so that extension author creating their own \fBTcl_ObjType\fR will be able to modify the string representation within the \fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (const char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any in-place modification of the string representation. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP \fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return a value's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned byte pointer is owned by the value manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the value's Unicode representation. .PP \fBTcl_GetRange\fR returns a newly created value comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated from the value's string representation. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. .PP \fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and \fIlength\fR to the string representation of the value specified by \fIobjPtr\fR. If the value has an invalid string representation, then an attempt is made to convert \fIbytes\fR is to the Unicode format. If the conversion is successful, then the converted form of \fIbytes\fR is appended to the value's Unicode representation. Otherwise, the value's Unicode representation is invalidated and converted to the UTF format, and \fIbytes\fR is appended to the value's new string representation. .PP \fBTcl_AppendUnicodeToObj\fR appends the Unicode string given by \fIunicode\fR and \fInumChars\fR to the value specified by \fIobjPtr\fR. If the value has an invalid Unicode representation, then \fIunicode\fR is converted to the UTF format and appended to the value's string representation. Appends are optimized to handle repeated appends relatively efficiently (it over-allocates the string or Unicode space to avoid repeated reallocations and copies of value's string value). .PP \fBTcl_AppendObjToObj\fR is similar to \fBTcl_AppendToObj\fR, but it appends the string or Unicode value (whichever exists and is best suited to be appended to \fIobjPtr\fR) of \fIappendObjPtr\fR to \fIobjPtr\fR. .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR | | | | | | | | | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | .CE .PP but with greater convenience and efficiency when the appending functionality is needed. .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR argument is greater than the space allocated for the value's string, then the string space is reallocated and the old value is copied to the new space; the bytes between the old length of the string and the new length may have arbitrary values. If the \fInewLength\fR argument is less than the current length of the value's string, with \fIobjPtr->length\fR is reduced without reallocating the string space; the original allocated size for the string is recorded in the value, so that the string length can be enlarged in a subsequent call to \fBTcl_SetObjLength\fR without reallocating storage. In all cases \fBTcl_SetObjLength\fR leaves a null character at \fIobjPtr->bytes[newLength]\fR. .PP \fBTcl_AttemptSetObjLength\fR is identical in function to \fBTcl_SetObjLength\fR except that if sufficient memory to satisfy the request cannot be allocated, it does not cause the Tcl interpreter to \fBpanic\fR. Thus, if \fInewLength\fR is greater than the space allocated for the value's string, and there is not enough memory available to satisfy the request, \fBTcl_AttemptSetObjLength\fR will take no action and return 0 to indicate failure. If there is enough memory to satisfy the request, \fBTcl_AttemptSetObjLength\fR behaves just like \fBTcl_SetObjLength\fR and returns 1 to indicate success. .PP The \fBTcl_ConcatObj\fR function returns a new string value whose value is the space-separated concatenation of the string representations of all of the values in the \fIobjv\fR array. \fBTcl_ConcatObj\fR eliminates leading and trailing white space as it copies the string representations of the \fIobjv\fR array to the result. If an element of the \fIobjv\fR array consists of nothing but white space, then that value is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. .SH "SEE ALSO" Tcl_NewObj(3), Tcl_IncrRefCount(3), Tcl_DecrRefCount(3), format(n), sprintf(3) .SH KEYWORDS append, internal representation, value, value type, string value, string type, string representation, concat, concatenate, unicode |
Changes to pkgs/msgcat/doc/SubstObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" 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_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" 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_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SubstObj \- perform substitutions on Tcl values .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_SubstObj\fR(\fIinterp, objPtr, flags\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute Tcl scripts and lookup variables. If an error occurs, the interpreter's result is modified to hold an error message. .AP Tcl_Obj *objPtr in A Tcl value containing the string to perform substitutions on. .AP int flags in ORed combination of flag bits that specify which substitutions to perform. The flags \fBTCL_SUBST_COMMANDS\fR, \fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are currently supported, and \fBTCL_SUBST_ALL\fR is provided as a convenience for the common case where all substitutions are desired. .BE .SH DESCRIPTION .PP The \fBTcl_SubstObj\fR function is used to perform substitutions on strings in the fashion of the \fBsubst\fR command. It gets the value of the string contained in \fIobjPtr\fR and scans it, copying characters and performing the chosen substitutions as it goes to an output value which is returned as the result of the function. In the event of an error occurring during the execution of a command or variable substitution, the function returns NULL and an error message is left in \fIinterp\fR's result. .PP Three kinds of substitutions are supported. When the \fBTCL_SUBST_BACKSLASHES\fR bit is set in \fIflags\fR, sequences that look like backslash substitutions for Tcl commands are replaced by |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/TCL_MEM_DEBUG.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | \fI\-\-enable\-symbols=mem\fR flag to the \fIconfigure\fR script when building). This will also compile in a non-stub version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl. .PP \fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined for all modules that are going to be linked together. If they are not, link errors will occur, with either \fBTcl_DbCkfree\fR and \fBTcl_DbCkalloc\fR or | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | \fI\-\-enable\-symbols=mem\fR flag to the \fIconfigure\fR script when building). This will also compile in a non-stub version of \fBTcl_InitMemory\fR to add the \fBmemory\fR command to Tcl. .PP \fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined for all modules that are going to be linked together. If they are not, link errors will occur, with either \fBTcl_DbCkfree\fR and \fBTcl_DbCkalloc\fR or \fBTcl_Alloc\fR and \fBTcl_Free\fR being undefined. .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/TclZlib.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 52 53 | \fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) .sp int \fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) .fi .SH ARGUMENTS | > > | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | \fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) .sp int \fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) .sp int \fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) .sp \fBTcl_ZlibStreamSetCompressionDictionary\fR(\fIzshandle, compDict\fR) .fi .SH ARGUMENTS .AS Tcl_ZlibStream zshandle in .AP Tcl_Interp *interp in The interpreter to store resulting compressed or uncompressed data in. Also where any error messages are written. For \fBTcl_ZlibStreamInit\fR, this can be NULL to create a stream that is not bound to a command. .AP int format in What format of compressed data to work with. Must be one of \fBTCL_ZLIB_FORMAT_ZLIB\fR for zlib-format data, \fBTCL_ZLIB_FORMAT_GZIP\fR for gzip-format data, or \fBTCL_ZLIB_FORMAT_RAW\fR for raw compressed data. In addition, for decompression only, \fBTCL_ZLIB_FORMAT_AUTO\fR may also be chosen which can automatically detect whether the compressed data was in zlib or gzip format. .AP Tcl_Obj *dataObj in/out A byte-array value containing the data to be compressed or decompressed, or to which the data extracted from the stream is appended when passed to \fBTcl_ZlibStreamGet\fR. .AP int level in What level of compression to use. Should be a number from 0 to 9 or one of the following: \fBTCL_ZLIB_COMPRESS_NONE\fR for no compression, \fBTCL_ZLIB_COMPRESS_FAST\fR for fast but inefficient compression, \fBTCL_ZLIB_COMPRESS_BEST\fR for slow but maximal compression, or |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib library by Jean-loup Gailly and Mark Adler. .PP \fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and decompress the data contained in the \fIdataObj\fR argument, according to the \fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in the \fIdictObj\fR parameter is used to convey additional header information about the compressed data when the compression format supports it; currently, the dictionary is only used when the \fIformat\fR parameter is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section below. Upon success, both functions leave the resulting compressed or | > > > > > > > | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to indicate whether a compression dictionary was present other than to fail on decompression. .BE .SH DESCRIPTION These functions form the interface from the Tcl library to the Zlib library by Jean-loup Gailly and Mark Adler. .PP \fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and decompress the data contained in the \fIdataObj\fR argument, according to the \fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in the \fIdictObj\fR parameter is used to convey additional header information about the compressed data when the compression format supports it; currently, the dictionary is only used when the \fIformat\fR parameter is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section below. Upon success, both functions leave the resulting compressed or decompressed data in a byte-array value that is the Tcl interpreter's result; the returned value is a standard Tcl result code. .PP \fBTcl_ZlibAdler32\fR and \fBTcl_ZlibCRC32\fR compute checksums on arrays of bytes, returning the computed checksum. Checksums are computed incrementally, allowing data to be processed one block at a time, but this requires the caller to maintain the current checksum and pass it in as the \fIinitValue\fR parameter; the initial value to use for this can be obtained by using NULL for |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | to be thread-safe; each stream should only ever be used from the thread that created it. When working with gzip streams, a dictionary (fields as given in the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the \fIdictObj\fR parameter that on compression allows control over the generated headers, and on decompression allows discovery of the existing headers. Note that the dictionary will be written to on decompression once sufficient data has been read to have a complete header. This means that the dictionary must | | | | > > > > > > > > > > > > > > > > > > > | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | to be thread-safe; each stream should only ever be used from the thread that created it. When working with gzip streams, a dictionary (fields as given in the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the \fIdictObj\fR parameter that on compression allows control over the generated headers, and on decompression allows discovery of the existing headers. Note that the dictionary will be written to on decompression once sufficient data has been read to have a complete header. This means that the dictionary must be an unshared value in that case; a blank value created with \fBTcl_NewObj\fR is suggested. .PP Once a stream has been constructed, \fBTcl_ZlibStreamPut\fR is used to add data to the stream and \fBTcl_ZlibStreamGet\fR is used to retrieve data from the stream after processing. Both return normal Tcl result codes and leave an error message in the result of the interpreter that the stream is registered with in the error case (if such a registration has been performed). With \fBTcl_ZlibStreamPut\fR, the data buffer value passed to it should not be modified afterwards. With \fBTcl_ZlibStreamGet\fR, the data buffer value passed to it will have the data bytes appended to it. Internally to the stream, data is kept compressed so as to minimize the cost of buffer space. .PP \fBTcl_ZlibStreamChecksum\fR returns the checksum computed over the uncompressed data according to the format, and \fBTcl_ZlibStreamEof\fR returns a boolean value indicating whether the end of the uncompressed data has been reached. .PP \fBTcl_ZlibStreamSetCompressionDictionary\fR is used to control the compression dictionary used with the stream, a compression dictionary being an array of bytes (such as might be created with \fBTcl_NewByteArrayObj\fR) that is used to initialize the compression engine rather than leaving it to create it on the fly from the data being compressed. Setting a compression dictionary allows for more efficient compression in the case where the start of the data is highly regular, but it does require both the compressor and the decompressor to agreee on the value to use. Compression dictionaries are only fully supported for zlib-format data; on compression, they must be set before any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its \fB\-errorcode\fR set to .QW "\fBZLIB NEED_DICT\fI code\fR" ; the \fIcode\fR will be the Adler-32 checksum (see \fBTcl_ZlibAdler32\fR) of the compression dictionary sought. (Note that this is only true for zlib-format streams; gzip streams ignore compression dictionaries as the format specification doesn't permit them, and raw streams just produce a data error if the compression dictionary is missing or incorrect.) .PP If you wish to clear a stream and reuse it for a new compression or decompression action, \fBTcl_ZlibStreamReset\fR will do this and return a normal Tcl result code to indicate whether it was successful; if the stream is registered with an interpreter, an error message will be left in the interpreter result when this function returns TCL_ERROR. Finally, \fBTcl_ZlibStreamClose\fR will clean up the stream and delete the associated command: using \fBTcl_DeleteCommand\fR on the stream's command is equivalent (when such a command exists). .SH "GZIP OPTIONS DICTIONARY" .PP The \fIdictObj\fR parameter to \fBTcl_ZlibDeflate\fR, \fBTcl_ZlibInflate\fR and \fBTcl_ZlibStreamInit\fR is used to pass a dictionary of options about that is used to describe the gzip header in the compressed data. When creating compressed data, the dictionary is read and when unpacking compressed data the dictionary is written (in which case the \fIdictObj\fR parameter must refer to an unshared dictionary value). .PP The following fields in the dictionary value are understood. All other fields are ignored. No field is required when creating a gzip-format stream. .TP \fBcomment\fR . This holds the comment field of the header, if present. If absent, no comment was supplied (on decompression) or will be created (on compression). .TP |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/WrongNumArgs.3.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | \fB#include <tcl.h>\fR .sp \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored in its result value. .AP int objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in Arguments to command that had the wrong number of arguments. .AP "const char" *message in Additional error information to print after leading arguments from \fIobjv\fR. This typically gives the acceptable syntax of the command. This argument may be NULL. .BE .SH DESCRIPTION .PP \fBTcl_WrongNumArgs\fR is a utility procedure that is invoked by command procedures when they discover that they have received the wrong number of arguments. \fBTcl_WrongNumArgs\fR generates a standard error message and stores it in the result value of \fIinterp\fR. The message includes the \fIobjc\fR initial elements of \fIobjv\fR plus \fImessage\fR. For example, if \fIobjv\fR consists of the values \fBfoo\fR and \fBbar\fR, \fIobjc\fR is 1, and \fImessage\fR is .QW "\fBfileName count\fR" then \fIinterp\fR's result value will be set to the following string: .PP .CS wrong # args: should be "foo fileName count" .CE .PP If \fIobjc\fR is 2, the result will be set to the following string: .PP .CS wrong # args: should be "foo bar fileName count" .CE .PP \fIObjc\fR is usually 1, but may be 2 or more for commands like \fBstring\fR and the Tk widget commands, which use the first argument as a subcommand. .PP Some of the values in the \fIobjv\fR array may be abbreviations for a subcommand. The command \fBTcl_GetIndexFromObj\fR will convert the abbreviated string value into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any \fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand name in the error message instead of the abbreviated name that was originally passed in. Using the above example, let us assume that \fIbar\fR is actually an abbreviation for \fIbarfly\fR and the value is now an \fIindexObject\fR because it was passed to \fBTcl_GetIndexFromObj\fR. In this case the error message would be: .PP .CS wrong # args: should be "foo barfly fileName count" .CE .SH "SEE ALSO" Tcl_GetIndexFromObj(3) .SH KEYWORDS command, error message, wrong number of arguments |
Changes to pkgs/msgcat/doc/dde.n.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the 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 | | > > | | | > > > | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the 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 . \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, \fIservice\fR is the name of an application. \fItopic\fR is application 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 . \fBdde request\fR is typically used to get the value of something; the value of a cell in Microsoft Excel or the text of a selection in Microsoft Word. \fIservice\fR is typically the name of an application, |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/define.n.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . .TP | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | supported values of \fIsubcommand\fR). It follows the same general pattern of argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, and .QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" operates identically to .QW "\fBoo::objdefine \fIcls subcommand ...\fR" . .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 |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/dict.n.
| ︙ | ︙ | |||
142 143 144 145 146 147 148 149 150 151 152 153 154 155 | . This appends the given items to the list value that the given 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 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. .TP \fBdict merge \fR?\fIdictionaryValue ...\fR? . Return a dictionary that contains the contents of each of the \fIdictionaryValue\fR arguments. Where two (or more) dictionaries contain a mapping for the same key, the resulting dictionary maps that key to the value according to the last dictionary on the command line | > > > > > > > > > > > > > > > > > > > > > > > > > | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
.
This appends the given items to the list value that the given 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 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.
.TP
\fBdict map \fR{\fIkeyVar valueVar\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
returning a new dictionary. It takes three arguments: the first is a
two-element list of variable names (for the key and value respectively of each
mapping in the dictionary), the second the dictionary value to iterate across,
and the third a script to be evaluated for each mapping with the key and value
variables set appropriately (in the manner of \fBlmap\fR). In an iteration
where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an
\fBerror\fR, etc.) the result of the script is put into an accumulator
dictionary using the key that is the current contents of the \fIkeyVar\fR
variable at that point. The result of the \fBdict map\fR command is the
accumulator dictionary after all keys have been iterated over.
.RS
.PP
If the evaluation of the body for any particular step generates a \fBbreak\fR,
no further pairs from the dictionary will be iterated over and the \fBdict
map\fR command will terminate successfully immediately. If the evaluation of
the body for a particular step generates a \fBcontinue\fR result, the current
iteration is aborted and the accumulator dictionary is not modified. The order
of iteration is the natural order of the dictionary (typically the order in
which the keys were added to the dictionary; the order is the same as that
used in \fBdict for\fR).
.RE
.TP
\fBdict merge \fR?\fIdictionaryValue ...\fR?
.
Return a dictionary that contains the contents of each of the
\fIdictionaryValue\fR arguments. Where two (or more) dictionaries
contain a mapping for the same key, the resulting dictionary maps that
key to the value according to the last dictionary on the command line
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
.CS
set foo {foo {a b} bar 2 baz 3}
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
| | | | 429 430 431 432 433 434 435 436 437 438 439 440 441 |
.CS
set foo {foo {a b} bar 2 baz 3}
\fBdict with\fR foo {}
puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
.SH KEYWORDS
dictionary, create, update, lookup, iterate, filter, map
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to pkgs/msgcat/doc/expr.n.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | 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 additional operators not found in C. .SS OPERANDS .PP A Tcl expression consists of a combination of operands, operators, | | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | 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 additional operators not found in C. .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, |
| ︙ | ︙ | |||
278 279 280 281 282 283 284 285 286 287 288 289 290 291 | .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). .PP See the \fBmathfunc\fR(n) manual page 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 | > > > > > > > > > > > > | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
.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).
.PP
Some mathematical functions have several arguments, separated by commas like in C. Thus:
.PP
.CS
\fBexpr\fR {hypot($x,$y)}
.CE
.PP
ends up as
.PP
.CS
tcl::mathfunc::hypot $x $y
.CE
.PP
See the \fBmathfunc\fR(n) manual page 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
|
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/fconfigure.n.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input or output. \fINewvalue\fR must be between one and one million, allowing buffers of one to one million bytes in size. .TP \fB\-encoding\fR \fIname\fR . This option is used to specify the encoding of the channel, so that the data can be converted to and from Unicode for use in Tcl. For instance, in order for Tcl to read characters from a Japanese file in \fBshiftjis\fR and properly process and display the contents, the encoding would be set |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/fileevent.n.
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP | | | | | | > > > | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP Event-driven I/O works best for channels that have been placed into nonblocking mode with the \fBfconfigure\fR command. In blocking mode, a \fBputs\fR command may block if you give it more data than the underlying file or device can accept, and a \fBgets\fR or \fBread\fR command will block if you attempt to read more data than is ready; a readable underlying file or device may not even guarantee that a blocking [read 1] will succeed (counter-examples being multi-byte encodings, compression or encryption transforms ). In all such cases, no events will be processed while the commands block. .PP In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. See the documentation for the individual commands for information on how they handle blocking and nonblocking channels. .PP Testing for the end of file condition should be done after any attempts read the channel data. The eof flag is set once an attempt to read the end of data has occurred and testing before this read will require an |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/load.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName\fR .br \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName\fR .br \fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName interp\fR .BE .SH DESCRIPTION .PP This command loads binary code from a file into the application's address space and calls an initialization procedure in the package to incorporate it into an interpreter. \fIfileName\fR is the name of the file containing the code; its exact form varies |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 | The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with .QW "library not found" error, it is also possible | > > > > > > > > > > > > > > > > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .PP If \fB\-global\fR is specified preceding the filename, all symbols found in the shared library are exported for global use by other libraries. The option \fB\-lazy\fR delays the actual loading of symbols until their first actual use. The options may be abbreviated. The option \fB\-\-\fR indicates the end of the options, and should be used if you wish to use a filename which starts with \fB\-\fR and you provide a packageName to the \fBload\fR command. .PP On platforms which do not support the \fB\-global\fR or \fB\-lazy\fR options, the options still exist but have no effect. Note that use of the \fB\-global\fR or \fB\-lazy\fR option may lead to crashes in your application later (in case of symbol conflicts resp. missing symbols), which cannot be detected during the \fBload\fR. So, only use this when you know what you are doing, you will not get a nice error message when something is wrong with the loaded library. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with .QW "library not found" error, it is also possible |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/msgcat.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros | | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" 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 "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp \fBpackage require msgcat 1.5.0\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp \fB::msgcat::mcpreferences\fR .sp \fB::msgcat::mcload \fIdirname\fR .sp \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp .VS "TIP 404" \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcflmset \fIsrc-trans-list\fR .VE "TIP 404" .sp \fB::msgcat::mcunknown \fIlocale src-string\fR .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
| > > > > > > > > > > > > > > > > > > > > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR?
.VS "TIP 404"
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the
current namespace for the locale implied by the name of the message catalog
being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not
specified, \fIsrc-string\fR is used for both. The function returns
\fItranslate-string\fR.
.VE "TIP 404"
.TP
\fB::msgcat::mcflmset \fIsrc-trans-list\fR
.VS "TIP 404"
Sets the translation for multiple source strings in \fIsrc-trans-list\fR in
the current namespace for the locale implied by the name of the message
catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must
have an even number of elements and is in the form {\fIsrc-string
translate-string\fR ?\fIsrc-string translate-string ...\fR?}
\fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations
of \fB::msgcat::mcflset\fR. The function returns the number of translations set.
.VE "TIP 404"
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
.
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP | | | > > > > | | < | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | to extract its parts. The initial locale is then set by calling \fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP On Windows and Cygwin, if none of those environment variables is set, msgcat will attempt to extract locale information from the registry. From Windows Vista on, the RFC4747 locale name "lang-script-country-options" is transformed to the locale as "lang_country_script" (Example: sr-Latn-CS -> sr_cs_latin). For Windows XP, the language id is transformed analoguously (Example: 0c1a -> sr_yu_cyrillic). If all these attempts to discover an initial locale from the user's environment fail, msgcat defaults to an initial locale of .QW C . .PP When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user specifies en_GB_Funky, the locales |
| ︙ | ︙ | |||
279 280 281 282 283 284 285 | is called .QW \fBROOT.msg\fR . This exception is made so as not to cause peculiar behavior, such as marking the message file as .QW hidden on Unix file systems. .IP [3] | | | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
is called
.QW \fBROOT.msg\fR .
This exception is made so as not to
cause peculiar behavior, such as marking the message file as
.QW hidden
on Unix file systems.
.IP [3]
The file contains a series of calls to \fBmcflset\fR and
\fBmcflmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.PP
.CS
namespace eval ::mypackage {
\fB::msgcat::mcflset\fR "Free Beer!" "Cerveza Gracias!"
}
.CE
.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
|
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/next.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" 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 next n 0.1 TclOO "TclOO Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" 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 next n 0.1 TclOO "TclOO Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME next, nextto \- invoke superclass method implementations .SH SYNOPSIS .nf package require TclOO \fBnext\fR ?\fIarg ...\fR? \fBnextto\fI class\fR ?\fIarg ...\fR? .fi |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/string.n.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: | < < < < < < < < < < < < < < < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically less than, equal to, or greater than \fIstring2\fR. If \fB\-length\fR is specified, then only the |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 | | > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 Any Unicode whitespace character, zero width space (U+200b), word joiner (U+2060) and zero width no-break space (U+feff) (=BOM). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional |
| ︙ | ︙ | |||
194 195 196 197 198 199 200 | will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR . Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the | | | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR . Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the number of bytes used to store the string. If the value is a byte array value (such as those returned from reading a binary encoded channel), then this will return the actual byte length of the value. .TP \fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR . Replaces substrings in \fIstring\fR based on the key-value pairs in \fImapping\fR. \fImapping\fR is a list of \fIkey value key value ...\fR as in the form returned by \fBarray get\fR. Each instance of a key in the string will be replaced with its corresponding value. If |
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). .SS "OBSOLETE SUBCOMMANDS" .PP These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. .TP \fBstring bytelength \fIstring\fR . Returns a decimal string giving the number of bytes used to represent \fIstring\fR in memory. Because UTF\-8 uses one to three bytes to represent Unicode characters, the byte length will not be the same as the character length in general. The cases where a script cares about the byte length are rare. .RS .PP In almost all cases, you should use the \fBstring length\fR operation (including determining the length of a Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. .PP \fICompatibility note:\fR it is likely that this subcommand will be withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. .RE .TP \fBstring wordend \fIstring charIndex\fR . Returns the index of the character just after the last one in the word containing character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be specified using the forms in \fBSTRING INDICES\fR. A word is considered to be any contiguous range of alphanumeric (Unicode letters |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/tclsh.1.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS \fBtclsh\fR ?\fB\-encoding \fIname\fR? ?\fIfileName arg arg ...\fR? .BE .SH DESCRIPTION .PP \fBTclsh\fR is a shell-like application that reads Tcl commands from its standard input or from a file and evaluates them. If invoked with no arguments then it runs interactively, reading Tcl commands from standard input and printing command results and |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/trace.n.
| ︙ | ︙ | |||
139 140 141 142 143 144 145 | course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .PP .CS | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: .PP .CS \fIcommandPrefix command-string code result op\fR .CE .PP \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an arbitrary command for a \fBenterstep\fR operation), including all arguments in their fully expanded form. \fICode\fR gives the result code of that execution, and \fIresult\fR |
| ︙ | ︙ |
Changes to pkgs/msgcat/doc/zlib.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2008-2012 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH zlib n 8.6 Tcl "Tcl Built-In Commands" .BS |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). | > > > > > > > | | < > | | > > | | > > > > > > > > > > > > > > > > < < < < < < < < | > > > > > > > > | | | | > > > | > > > > | | > > > > > | | | | > > > > > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | The transformation will be a decompressing transformation that reads raw compressed data from \fIchannel\fR, which must be readable. .PP The following options may be set when creating a transformation via the .QW "\fIoptions ...\fR" to the \fBzlib push\fR command: .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. Not valid for transformations that work with gzip-format data. .VE .TP \fB\-header\fI dictionary\fR . Passes a description of the gzip header to create, in the same format that \fBzlib gzip\fR understands. .TP \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . The maximum number of bytes ahead to read when decompressing. This defaults to 1, which ensures that data is always decompressed correctly, but may be increased to improve performance. This is more useful when the channel is non-blocking. .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: .TP \fB\-checksum\fI checksum\fR . This read-only option gets the current checksum for the uncompressed data that the compression engine has seen so far. It is valid for both compressing and decompressing transforms, but not for the raw inflate and deflate formats. The compression algorithm depends on what format is being produced or consumed. .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" This read-write options gets or sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. It is not valid for transformations that work with gzip-format data, and should not normally be set on compressing transformations other than at the point where the transformation is stacked. .VE .TP \fB\-flush\fI type\fR . This write-only operation flushes the current state of the compressor to the underlying channel. It is only valid for compressing transformations. The \fItype\fR must be either \fBsync\fR or \fBfull\fR for a normal flush or an expensive flush respectively. Flushing degrades the compression ratio, but makes it easier for a decompressor to recover more of the file in the case of data corruption. .TP \fB\-header\fI dictionary\fR . This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the maximum number of bytes ahead to read from the underlying data source. This defaults to 1, which ensures that data is always decompressed correctly, but may be increased to improve performance. This is more useful when the channel is non-blocking. .RE .SS "STREAMING SUBCOMMAND" .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes and \fIoptions\fR are supported: .RS .TP \fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, .VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). .VE .TP \fBzlib stream decompress\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. .VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use if required. .VE .TP \fBzlib stream deflate\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, .VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). Note that the raw compressed data includes no metadata about what compression dictionary was used, if any; that is a feature of the zlib-format data. .VE .TP \fBzlib stream gunzip\fR . The stream will be a decompressing stream that takes gzip-format input and produces uncompressed output. .TP \fBzlib stream gzip\fR ?\fB\-header \fIheader\fR? ?\fB\-level \fIlevel\fR? . The stream will be a compressing stream that produces gzip-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, and the header descriptor dictionary \fIheader\fR (if specified; for keys see \fBzlib gzip\fR). .TP \fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? . The stream will be a decompressing stream that takes raw compressed input and produces uncompressed output. .VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that there are no checks in place to determine whether the compression dictionary is correct. .VE .RE .SS "CHECKSUMMING SUBCOMMANDS" .TP \fBzlib adler32\fI string\fR ?\fIinitValue\fR? . Compute a checksum of binary string \fIstring\fR using the Adler-32 algorithm. If given, \fIinitValue\fR is used to initialize the checksum engine. |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | command. They are used by calling their \fBput\fR subcommand one or more times to load data in, and their \fBget\fR subcommand one or more times to extract the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP | | | | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | command. They are used by calling their \fBput\fR subcommand one or more times to load data in, and their \fBget\fR subcommand one or more times to extract the transformed data. .PP The full set of subcommands supported by a streaming instance command, \fIstream\fR, is as follows: .TP \fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR . A short-cut for .QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" followed by .QW "\fIstream \fBget\fR" . .TP \fIstream \fBchecksum\fR . Returns the checksum of the uncompressed data seen so far by this stream. .TP |
| ︙ | ︙ | |||
314 315 316 317 318 319 320 321 |
.QW "\fIstream \fBput \-fullflush {}\fR" .
.TP
\fIstream \fBget \fR?\fIcount\fR?
.
Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the
transformation applied. If \fIcount\fR is omitted, the entire contents of the
buffers are returned.
.TP
| > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
.QW "\fIstream \fBput \-fullflush {}\fR" .
.TP
\fIstream \fBget \fR?\fIcount\fR?
.
Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the
transformation applied. If \fIcount\fR is omitted, the entire contents of the
buffers are returned.
.
\fIstream \fBheader\fR
.
Return the gzip header description dictionary extracted from the stream. Only
supported for streams created with their \fImode\fR parameter set to
\fBgunzip\fR.
.TP
\fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR
.
Append the contents of the binary string \fIdata\fR to \fIstream\fR's internal
buffers while applying the transformation. The following \fIoption\fRs are
supported (or an unambiguous prefix of them), which are used to modify the
way in which the transformation is applied:
.RS
.TP
\fB\-dictionary\fI binData\fR
.VS "TIP 400"
Sets the compression dictionary to use when working with compressing or
decompressing the data to be \fIbinData\fR.
.VE
.TP
\fB\-finalize\fR
.
Mark the stream as finished, ensuring that all bytes have been wholly
compressed or decompressed. For gzip streams, this also ensures that the
footer is written to the stream. The stream will need to be reset before
having more data written to it after this, though data can still be read out
of the stream with the \fBget\fR subcommand.
.RS
.PP
This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR
options.
.RE
.TP
\fB\-flush\fR
.
Ensure that a decompressor consuming the bytes that the current (compressing)
stream is producing will be able to produce all the bytes that have been
compressed so far, at some performance penalty.
.RS
.PP
This option is mutually exclusive with the \fB\-finalize\fR and
\fB\-fullflush\fR options.
.RE
.TP
\fB\-fullflush\fR
.
Ensure that not only can a decompressor handle all the bytes produced so far
(as with \fB\-flush\fR above) but also that it can restart from this point if
it detects that the stream is partially corrupt. This incurs a substantial
performance penalty.
.RS
.PP
This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR
options.
.RE
.RE
.TP
\fIstream \fBreset\fR
.
Puts any stream, including those that have been finalized or that have reached
eof, back into a state where it can process more data. Throws away all
internally buffered data.
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | $\fIstrm \fBfinalize\fR set compData [$\fIstrm \fBget\fR] $\fIstrm \fBclose\fR .CE .SH "SEE ALSO" binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 .SH "KEYWORDS" | | | 450 451 452 453 454 455 456 457 458 459 460 | $\fIstrm \fBfinalize\fR set compData [$\fIstrm \fBget\fR] $\fIstrm \fBclose\fR .CE .SH "SEE ALSO" binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 .SH "KEYWORDS" compress, decompress, deflate, gzip, inflate, zlib '\" Local Variables: '\" mode: nroff '\" End: |
Changes to pkgs/msgcat/msgcat.tcl.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. | | | > > > | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
#
# 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
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.5.0
namespace eval msgcat {
namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
mcunknown mcflset mcflmset
# Records the current locale as passed to mclocale
variable Locale ""
# Records the list of locales to search
variable Loclist {}
# Records the locale of the currently sourced message catalogue file
variable FileLocale
# Records the mapping between source strings and translated strings. The
# dict key is of the form "<locale> <namespace> <src>", where locale and
# namespace should be themselves dict values and the value is
# the translated string.
variable Msgs [dict create]
# Map of language codes used in Windows registry to those of ISO-639
if {[info sharedlibextension] eq ".dll"} {
variable WinRegToISO639 [dict create {*}{
01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
4001 ar_QA
02 bg 0402 bg_BG
03 ca 0403 ca_ES
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | 11 ja 0411 ja_JP 12 ko 0412 ko_KR 13 nl 0413 nl_NL 0813 nl_BE 14 no 0414 no_NO 0814 nn_NO 15 pl 0415 pl_PL 16 pt 0416 pt_BR 0816 pt_PT 17 rm 0417 rm_CH | | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | 11 ja 0411 ja_JP 12 ko 0412 ko_KR 13 nl 0413 nl_NL 0813 nl_BE 14 no 0414 no_NO 0814 nn_NO 15 pl 0415 pl_PL 16 pt 0416 pt_BR 0816 pt_PT 17 rm 0417 rm_CH 18 ro 0418 ro_RO 0818 ro_MO 19 ru 0819 ru_MO 1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic 1b sk 041b sk_SK 1c sq 041c sq_AL 1d sv 041d sv_SE 081d sv_FI 1e th 041e th_TH 1f tr 041f tr_TR 20 ur 0420 ur_PK 0820 ur_IN |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 95 96 97 98 99 100 101 | 2b hy 042b hy_AM 2c az 042c az_AZ@latin 082c az_AZ@cyrillic 2d eu 2e wen 042e wen_DE 2f mk 042f mk_MK 30 bnt 0430 bnt_TZ 31 ts 0431 ts_ZA 33 ven 0433 ven_ZA 34 xh 0434 xh_ZA 35 zu 0435 zu_ZA 36 af 0436 af_ZA 37 ka 0437 ka_GE 38 fo 0438 fo_FO 39 hi 0439 hi_IN | > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | 2b hy 042b hy_AM 2c az 042c az_AZ@latin 082c az_AZ@cyrillic 2d eu 2e wen 042e wen_DE 2f mk 042f mk_MK 30 bnt 0430 bnt_TZ 31 ts 0431 ts_ZA 32 tn 33 ven 0433 ven_ZA 34 xh 0434 xh_ZA 35 zu 0435 zu_ZA 36 af 0436 af_ZA 37 ka 0437 ka_GE 38 fo 0438 fo_FO 39 hi 0439 hi_IN |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
# Arguments:
# langdir The directory to search.
#
# Results:
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
set x 0
foreach p [mcpreferences] {
if { $p eq {} } {
set p ROOT
}
set langfile [file join $langdir $p.msg]
if {[file exists $langfile]} {
incr x
uplevel 1 [list ::source -encoding utf-8 $langfile]
}
}
return $x
}
# msgcat::mcset --
#
# Set the translation for a given string in a specified locale.
| > > > > > > > > > > > > > | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
# Arguments:
# langdir The directory to search.
#
# Results:
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
variable FileLocale
# Save the file locale if we are recursively called
if {[info exists FileLocale]} {
set nestedFileLocale $FileLocale
}
set x 0
foreach p [mcpreferences] {
if { $p eq {} } {
set p ROOT
}
set langfile [file join $langdir $p.msg]
if {[file exists $langfile]} {
incr x
set FileLocale [string tolower [file tail [file rootname $langfile]]]
if {"root" eq $FileLocale} {
set FileLocale ""
}
uplevel 1 [list ::source -encoding utf-8 $langfile]
unset FileLocale
}
}
if {[info exists nestedFileLocale]} {
set FileLocale $nestedFileLocale
}
return $x
}
# msgcat::mcset --
#
# Set the translation for a given string in a specified locale.
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
set ns [uplevel 1 [list ::namespace current]]
set locale [string tolower $locale]
dict set Msgs $locale $ns $src $dest
return $dest
}
# msgcat::mcmset --
#
# Set the translation for multiple strings in a specified locale.
#
# Arguments:
# locale The locale to use.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 |
set ns [uplevel 1 [list ::namespace current]]
set locale [string tolower $locale]
dict set Msgs $locale $ns $src $dest
return $dest
}
# msgcat::mcflset --
#
# Set the translation for a given string in the current file locale.
#
# Arguments:
# src The source string.
# dest (Optional) The translated string. If omitted,
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcflset {src {dest ""}} {
variable FileLocale
variable Msgs
if {![info exists FileLocale]} {
return -code error \
"must only be used inside a message catalog loaded with ::msgcat::mcload"
}
if {[llength [info level 0]] == 2} { ;# dest not specified
set dest $src
}
set ns [uplevel 1 [list ::namespace current]]
dict set Msgs $FileLocale $ns $src $dest
return $dest
}
# msgcat::mcmset --
#
# Set the translation for multiple strings in a specified locale.
#
# Arguments:
# locale The locale to use.
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
should be \"[lindex [info level 0] 0] locale {src dest ...}\""
}
set locale [string tolower $locale]
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
| | > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
should be \"[lindex [info level 0] 0] locale {src dest ...}\""
}
set locale [string tolower $locale]
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
dict set Msgs $locale $ns $src $dest
}
return [expr {$length / 2}]
}
# msgcat::mcflmset --
#
# Set the translation for multiple strings in the mc file locale.
#
# Arguments:
# pairs One or more src/dest pairs (must be even length)
#
# Results:
# Returns the number of pairs processed
proc msgcat::mcflmset {pairs} {
variable FileLocale
variable Msgs
if {![info exists FileLocale]} {
return -code error \
"must only be used inside a message catalog loaded with ::msgcat::mcload"
}
set length [llength $pairs]
if {$length % 2} {
return -code error "bad translation list:\
should be \"[lindex [info level 0] 0] locale {src dest ...}\""
}
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
dict set Msgs $FileLocale $ns $src $dest
}
return [expr {$length / 2}]
}
# msgcat::mcunknown --
#
# This routine is called by msgcat::mc if a translation cannot
# be found for a string. This routine is intended to be replaced
# by an application specific routine for error reporting
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
# Results:
# Returns the length of the longest translated string.
proc msgcat::mcmax {args} {
set max 0
foreach string $args {
set translated [uplevel 1 [list [namespace origin mc] $string]]
| | | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
# Results:
# Returns the length of the longest translated string.
proc msgcat::mcmax {args} {
set max 0
foreach string $args {
set translated [uplevel 1 [list [namespace origin mc] $string]]
set len [string length $translated]
if {$len>$max} {
set max $len
}
}
return $max
}
# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
proc msgcat::ConvertLocale {value} {
|
| ︙ | ︙ | |||
422 423 424 425 426 427 428 |
append ret _$modifier
}
return $ret
}
# Initialize the default locale
proc msgcat::Init {} {
| | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
append ret _$modifier
}
return $ret
}
# Initialize the default locale
proc msgcat::Init {} {
global env
#
# set default locale, try to get from environment
#
foreach varName {LC_ALL LC_MESSAGES LANG} {
if {[info exists env($varName)] && ("" ne $env($varName))} {
if {![catch {
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
if {![catch {
mclocale [ConvertLocale $::tcl::mac::locale]
}]} {
return
}
}
#
| | | | > | | | | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
if {![catch {
mclocale [ConvertLocale $::tcl::mac::locale]
}]} {
return
}
}
#
# The rest of this routine is special processing for Windows or
# Cygwin. All other platforms, get out now.
#
if {([info sharedlibextension] ne ".dll")
|| [catch {package require registry}]} {
mclocale C
return
}
#
# On Windows or Cygwin, try to set locale depending on registry
# settings, or fall back on locale of "C".
#
# First check registry value LocalName present from Windows Vista
# which contains the local string as RFC5646, composed of:
# [a-z]{2,3} : language
# -[a-z]{4} : script (optional, translated by table Latn->latin)
# -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used)
# (-.*)* : variant, extension, private use (optional, not used)
# Those are translated to local strings.
# Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es
#
set key {HKEY_CURRENT_USER\Control Panel\International}
if {([registry values $key "LocaleName"] ne "")
&& [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\
[string tolower [registry get $key "LocaleName"]] match locale\
script territory]} {
if {"" ne $territory} {
append locale _ $territory
}
set modifierDict [dict create latn latin cyrl cyrillic]
if {[dict exists $modifierDict $script]} {
append locale @ [dict get $modifierDict $script]
}
if {![catch {
mclocale [ConvertLocale $locale]
}]} {
return
}
}
# then check key locale which contains a numerical language ID
if {[catch {
set locale [registry get $key "locale"]
}]} {
mclocale C
return
}
#
# 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
# more precise information, such as territory. For example,
|
| ︙ | ︙ |
Changes to pkgs/msgcat/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]]
|
Changes to pkgs/msgcat/tests/assocd.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
} ""
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
} ""
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/async.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/basic.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#
# 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::*
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#
# 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
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/binary.test.
| ︙ | ︙ | |||
2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
test binary-73.23 {binary decode base64} -body {
set r [binary decode base64 YWJj]
list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
string length [binary decode base64 " "]
} -result 0
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
| > > > > > > > > > > > > > > > > > > > > > | 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 |
test binary-73.23 {binary decode base64} -body {
set r [binary decode base64 YWJj]
list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
string length [binary decode base64 " "]
} -result 0
test binary-73.25 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==\n]]] $r
} -result {1 X}
test binary-73.26 {binary decode base64} -body {
list [string length [set r [binary decode base64 WFk=\n]]] $r
} -result {2 XY}
test binary-73.27 {binary decode base64} -body {
list [string length [set r [binary decode base64 WFla\n]]] $r
} -result {3 XYZ}
test binary-73.28 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WA==\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/chan.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
chan configure stdout -eofchar [list \x27 {}]
} -returnCodes ok -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
chan configure stdout -eofchar [list \x27 {}]
} -returnCodes ok -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
test chan-6.1 {chan command: eof subcommand} -body {
chan eof foo bar
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/chanio.test.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
| > > > | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
variable f
variable i
variable n
variable v
variable msg
variable expected
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport 0
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/clock.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
| < < | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
package require registry
}]} {
namespace eval ::tcl::clock {variable NoRegistry {}}
}
}
package require msgcat 1.4
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/cmdAH.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
([string index $tcl_platform(osVersion) 0] >= 5
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
([string index $tcl_platform(osVersion) 0] >= 5
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch foo bar baz spaz
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd foo bar
} -result {wrong # args: should be "cd ?dirName?"}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} -setup {
file delete -force $foodir
| > > > > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch foo bar baz spaz
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.4 {Bug 3595576} {
catch {catch {} -> noSuchNs::var}
} 1
test cmdAH-1.5 {Bug 3595576} {
catch {catch error -> noSuchNs::var}
} 1
test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd foo bar
} -result {wrong # args: should be "cd ?dirName?"}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} -setup {
file delete -force $foodir
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/cmdIL.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/cmdInfo.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/compExpr-old.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
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]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/compExpr.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Constrain memory leak tests
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Constrain memory leak tests
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/compile.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # # 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::* testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. | > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # # 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 catch [list package require -exact Tcltest [info patchlevel]] testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. |
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/coroutine.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/dcall.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
testdcall
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
testdcall
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/dict.test.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
test dict-3.3 {dict get command} {dict get {a b c d} c} d
test dict-3.4 {dict get command} -returnCodes error -body {
dict get {a b c d} b
} -result {key "b" not known in dictionary}
| > > > > > > > > > > > > > > > > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
test dict-2.9 {dict create command: compilation} {
apply {{} {dict create [format a] b}}
} {a b}
test dict-2.10 {dict create command: compilation} {
apply {{} {dict create [format a] b c d}}
} {a b c d}
test dict-2.11 {dict create command: compilation} {
apply {{} {dict create [format a] b c d a x}}
} {a x c d}
test dict-2.12 {dict create command: non-compilation} {
dict create [format a] b
} {a b}
test dict-2.13 {dict create command: non-compilation} {
dict create [format a] b c d
} {a b c d}
test dict-2.14 {dict create command: non-compilation} {
dict create [format a] b c d a x
} {a x c d}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
test dict-3.3 {dict get command} {dict get {a b c d} c} d
test dict-3.4 {dict get command} -returnCodes error -body {
dict get {a b c d} b
} -result {key "b" not known in dictionary}
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 784 785 786 787 788 789 790 |
unset -nocomplain dictVar
} -body {
set dictVar(block) {}
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-17.1 {dict filter command: key} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict filter $dictVar key a2
} -cleanup {
unset dictVar
} -result {a2 b}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
unset -nocomplain dictVar
} -body {
set dictVar(block) {}
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {can't set "dictVar": variable is array}
# Now test with an LVT present (i.e., the bytecoded version).
test dict-16.10 {dict unset command} -body {
apply {{} {
set dictVar {a b c d}
dict unset dictVar a
}}
} -result {c d}
test dict-16.11 {dict unset command} -body {
apply {{} {
set dictVar {a b c d}
dict unset dictVar c
}}
} -result {a b}
test dict-16.12 {dict unset command} -body {
apply {{} {
set dictVar {a b}
dict unset dictVar c
}}
} -result {a b}
test dict-16.13 {dict unset command} -body {
apply {{} {
set dictVar {a {b c d e}}
dict unset dictVar a b
}}
} -result {a {d e}}
test dict-16.14 {dict unset command} -returnCodes error -body {
apply {{} {
set dictVar a
dict unset dictVar a
}}
} -result {missing value to go with key}
test dict-16.15 {dict unset command} -returnCodes error -body {
apply {{} {
set dictVar {a b}
dict unset dictVar c d
}}
} -result {key "c" not known in dictionary}
test dict-16.16 {dict unset command} -body {
apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}}
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
apply {{} {dict unset dictVar}}
} -result {wrong # args: should be "dict unset varName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
apply {{} {
set dictVar(block) {}
dict unset dictVar a
}}
} -returnCodes error -result {can't set "dictVar": variable is array}
test dict-17.1 {dict filter command: key} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict filter $dictVar key a2
} -cleanup {
unset dictVar
} -result {a2 b}
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
} {a x c y}
test dict-20.9 {dict merge command} {
dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 |
} {a x c y}
test dict-20.9 {dict merge command} {
dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
test dict-20.11 {dict merge command} {
apply {{} {dict merge}}
} {}
test dict-20.12 {dict merge command} {
apply {{} {dict merge {a b c d e f}}}
} {a b c d e f}
test dict-20.13 {dict merge command} -body {
apply {{} {dict merge {a b c d e}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.14 {dict merge command} {
apply {{} {dict merge {a b c d} {e f g h}}}
} {a b c d e f g h}
test dict-20.15 {dict merge command} -body {
apply {{} {dict merge {a b c d e} {e f g h}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.16 {dict merge command} -body {
apply {{} {dict merge {a b c d} {e f g h i}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.17 {dict merge command} {
apply {{} {dict merge {a b c d e f} {e x g h}}}
} {a b c d e x g h}
test dict-20.18 {dict merge command} {
apply {{} {dict merge {a b c d} {a x c y}}}
} {a x c y}
test dict-20.19 {dict merge command} {
apply {{} {dict merge {a b c d} {c y a x}}}
} {a x c y}
test dict-20.20 {dict merge command} {
apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 |
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
dict map
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
dict map x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
dict map x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
dict map x x x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
dict map x x x
} -result {must have exactly two variable names}
test dict-24.6 {dict map command: syntax} -returnCodes error -body {
dict map {x x x} x x
} -result {must have exactly two variable names}
test dict-24.7 {dict map command: syntax} -returnCodes error -body {
dict map "\{x" x x
} -result {unmatched open brace in list}
test dict-24.8 {dict map command} -setup {
set values {}
set keys {}
} -body {
# This test confirms that [dict keys], [dict values] and [dict map]
# all traverse a dictionary in the same order.
set dictv {a A b B c C}
dict map {k v} $dictv {
lappend keys $k
lappend values $v
}
set result [expr {
$keys eq [dict keys $dictv] && $values eq [dict values $dictv]
}]
expr {$result ? "YES" : [list "NO" $dictv $keys $values]}
} -cleanup {
unset result keys values k v dictv
} -result YES
test dict-24.9 {dict map command} {
dict map {k v} {} {
error "unexpected execution of 'dict map' body"
}
} {}
test dict-24.10 {dict map command: script results} -body {
set times 0
dict map {k v} {a a b b} {
incr times
continue
error "shouldn't get here"
}
return $times
} -cleanup {
unset times k v
} -result 2
test dict-24.11 {dict map command: script results} -body {
set times 0
dict map {k v} {a a b b} {
incr times
break
error "shouldn't get here"
}
return $times
} -cleanup {
unset times k v
} -result 1
test dict-24.12 {dict map command: script results} -body {
set times 0
list [catch {
dict map {k v} {a a b b} {
incr times
error test
}
} msg] $msg $times $::errorInfo
} -cleanup {
unset times k v msg
} -result {1 test 1 {test
while executing
"error test"
("dict map" body line 3)
invoked from within
"dict map {k v} {a a b b} {
incr times
error test
}"}}
test dict-24.13 {dict map command: script results} {
apply {{} {
dict map {k v} {a b} {
return ok,$k,$v
error "skipped return completely"
}
error "return didn't go far enough"
}}
} ok,a,b
test dict-24.14 {dict map command: handle representation loss} -setup {
set keys {}
set values {}
} -body {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[llength $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values]
} -cleanup {
unset dictVar keys values k v
} -result {4 {a c e g} {b d f h}}
test dict-24.14a {dict map command: handle representation loss} -body {
apply {{} {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[llength $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values]
}}
} -result {4 {a c e g} {b d f h}}
test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup {
unset -nocomplain accum
array set accum {}
} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict map {k v} $dictVar {
append accum($k) $v,
}
set result [lsort [array names accum]]
lappend result :
foreach k $result {
catch {lappend result $accum($k)}
}
return $result
} -cleanup {
unset dictVar k v result accum
} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
test dict-24.16 {dict map command in compilation context} {
apply {{} {
set res {x x x x x x}
dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
lset res $v $k
continue
}
return $res
}}
} {a b c d e f}
test dict-24.17 {dict map command in compilation context} {
# Bug 1379349 (dict for)
apply {{} {
set d [dict create a 1] ;# Dict must be unshared!
dict map {k v} $d {
dict set d $k 0 ;# Any modification will do
}
return $d
}}
} {a 0}
test dict-24.17a {dict map command in compilation context} {
# Bug 1379349 (dict for)
apply {{} {
set d [dict create a 1] ;# Dict must be unshared!
dict map {k v} $d {
dict set d $k 0 ;# Any modification will do
}
}}
} {a {a 0}}
test dict-24.18 {dict map command in compilation context} {
# Bug 1382528 (dict for)
apply {{} {
dict map {k v} {} {} ;# Note empty dict
catch { error foo } ;# Note compiled [catch]
}}
} 1
test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body {
di[list]ct map {k v} x {}
} -returnCodes 1 -result {missing value to go with key}
test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} {
apply {{x y args} {
dict map {a b} $x {}
concat "c=$y,$args"
}} {} 1 2 3
} {c=1,2 3}
proc linenumber {} {
dict get [info frame -1] line
}
test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} {
apply {{} {apply {n {
set e {}
set k {}
dict map {a b} {c {d {e {f g}}}} {
::tcl::dict::map {h i} $b {
dict update i e j {
::tcl::dict::update j f k {
return [expr {$n - [linenumber]}]
}
}
}
}
}} [linenumber]}}
} 5
test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug {
apply {{} {apply {n {
set e {}
set k {}
dict map {a {
b
}} {c {d {e {f g}}}} {
::tcl::dict::map {h {
i
}} ${
b
} {
dict update {
i
} e {
j
} {
::tcl::dict::update {
j
} f k {
return [expr {$n - [linenumber]}]
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.22 {dict map results (non-compiled)} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
return -level 0 "$k,$v"
}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.23 {dict map results (compiled)} {
apply {{} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
return -level 0 "$k,$v"
}
}}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.23a {dict map results (compiled)} {
apply {{list} {
dict map {k v} [dict map {k v} $list { list $v $k }] {
return -level 0 "$k,$v"
}
}} {a 1 b 2 c 3 d 4}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.24 {dict map with huge dict (non-compiled)} {
tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] {
expr { $k * $v }
}]
} 166666666600000
test dict-24.25 {dict map with huge dict (compiled)} {
apply {{n} {
tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] {
expr { $k * $v }
}]
}} 100000
} 166666666600000
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/dstring.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
testdstring free
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
testdstring free
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/encoding.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
package require tcltest 2
namespace eval ::tcl::test::encoding {
variable x
namespace import -force ::tcltest::*
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
variable x
lappend x "fromutf $args"
}
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
| > > > > > < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
package require tcltest 2
namespace eval ::tcl::test::encoding {
variable x
namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
}
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
variable x
lappend x "fromutf $args"
}
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
set old [encoding system]
} -constraints {testencoding} -body {
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
test encoding-24.1 {EscapeFreeProc on open channels} exec {
runInSubprocess {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
| | > | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
test encoding-24.1 {EscapeFreeProc on open channels} exec {
runInSubprocess {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab\u4e4e\u68d9g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}]
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
test encoding-27.1 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs ? ?
} -result {wrong # args: should be "encoding dirs ?dirList?"}
test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs "\{not a list"
} -result "expected directory list but got \"\{not a list\""
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/env.test.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
| | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
return [subst -novariables $s]
}
proc manglechar c {
return [format {\u%04x} [scan $c %c]]
}
set names [lsort [array names env]]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/event.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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::*
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 |
# file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
| > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
# file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/exec.test.
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
set sysenc [encoding system]
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
| | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
set sysenc [encoding system]
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u007f-\uffff\]" $s \
{[apply {c {format {\u%04x} [scan $c %c]}} &]} s
return [subst -novariables $s]
}
} -constraints {exec} -body {
# If this fails, it may give back: "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
# If it does, this means that the UTF -> external conversion did not occur
# before writing out the temp file.
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/execute.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
testConstraint testobj [expr {
| > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
testConstraint testobj [expr {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/expr-old.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
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
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/expr.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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.
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::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.
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/fCmd.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
# Don't know how to determine this constraint correctly
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
# Don't know how to determine this constraint correctly
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/fileName.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {[string index $tcl_platform(osVersion) 0] < 5 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {[string index $tcl_platform(osVersion) 0] < 5 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
| | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
} "/ foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
} {foo bar}
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
| | | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
} "/a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} "/a/b"
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join a b
} {a/b}
test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
file join [lindex [glob ~] 0]
} [file join $env(HOME)]
set oldpwd [pwd]
set oldhome $env(HOME)
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
file join [lindex [glob ~] 0]
} [file join $env(HOME)]
set oldpwd [pwd]
set oldhome $env(HOME)
catch {cd [makeDirectory tcl[pid]]}
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
touch globTest/x1.c
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 |
} -result ~/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
} -result ~/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
catch {removeDirectory tcl[pid]}
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/fileSystem.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
namespace import ::tcltest::*
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
cd [tcltest::temporaryDirectory]
| > > > > > > > > > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
namespace import ::tcltest::*
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
testConstraint loaddll 0
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::ddever [package require dde]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
set ::regver [package require registry]
set ::reglib [lindex [package ifneeded registry $::regver] 1]
testConstraint loaddll 1
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
cd [tcltest::temporaryDirectory]
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
set old [pwd]
} -constraints {win} -body {
set drv C:/
cd [lindex [glob -type d -dir $drv *] 0]
file norm [string range $drv 0 1]
} -cleanup {
cd $old
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
set old [pwd]
} -constraints {win} -body {
set drv C:/
cd [lindex [glob -type d -dir $drv *] 0]
file norm [string range $drv 0 1]
} -cleanup {
cd $old
} -match regexp -result {.*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
testPathEqual [file norm foo////bar] [file norm foo/bar]
} ok
test filesystem-1.41 {file normalisation with repeated separators} {win} {
testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]
} ok
test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
test filesystem-6.19 {empty file name} {file nativename ""} {}
test filesystem-6.20 {empty file name} {file normalize ""} {}
test filesystem-6.21 {empty file name} {file owned ""} 0
test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
| | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
test filesystem-6.19 {empty file name} {file nativename ""} {}
test filesystem-6.20 {empty file name} {file normalize ""} {}
test filesystem-6.21 {empty file name} {file owned ""} 0
test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
} -result {could not read link "": no such file or directory}
test filesystem-6.25 {empty file name} -returnCodes error -body {
file rename "" ""
} -result {error renaming "": no such file or directory}
test filesystem-6.26 {empty file name} {file rootname ""} {}
test filesystem-6.27 {empty file name} -returnCodes error -body {
file separator ""
} -result {unrecognised path}
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
| | | < | | | < | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::ddelib]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
load simplefs:/[file tail $::ddelib] dde
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads reg via a complex copy-to-temp operation
load simplefs:/[file tail $::reglib] Registry
unload simplefs:/[file tail $::reglib]
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/foreach.test.
| ︙ | ︙ | |||
261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
# cleanup
catch {unset a}
catch {unset x}
catch {rename foo {}}
::tcltest::cleanupTests
return
| > > > > > > > > > | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
test foreach-11.1 {error then dereference loop var (dev bug)} {
catch { foreach a 0 b {1 2 3} { error x } }
set a
} 0
test foreach-11.2 {error then dereference loop var (dev bug)} {
catch { foreach a 0 b {1 2 3} { incr a $b; error x } }
set a
} 1
# cleanup
catch {unset a}
catch {unset x}
catch {rename foo {}}
::tcltest::cleanupTests
return
|
Changes to pkgs/msgcat/tests/format.test.
| ︙ | ︙ | |||
545 546 547 548 549 550 551 |
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
| < | < < | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
format %llx 0
} 0
test format-19.3 {Bug 2830354} {
string length [format %340f 0]
} 340
# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
set x [dict create a b c d]
format %s $x
# After this, obj in $x should be a dict with a non-NULL bytes field
tcl::unsupported::representation $x
} -match glob -result {value is a dict with *, string representation "*"}
# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/get.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/http.test.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
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}
puts "Running httpd in thread $httpthread"
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
| > | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
} -match regexp -result {(?n)Accept \*/\*
Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
| > > > > > > > > > > > > > > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
} -match regexp -result {(?n)Accept \*/\*
Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
test http-3.29 "http::geturl $ipv6url" -body {
# We only want to see if the URL gets parsed correctly. This is
# the case if http::geturl succeeds or returns a socket related
# error. If the parsing is wrong, we'll get a parse error.
# It'd be better to separate the URL parser from http::geturl, so
# that it can be tested without also trying to make a connection.
set error [catch {http::geturl $ipv6url -validate 1} token]
if {$error && [string match "couldn't open socket: *" $token]} {
set error 0
}
set error
} -cleanup {
catch { http::cleanup $token }
} -result 0
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/indexObj.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/info.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
| > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
| < | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
test info-7.1 {info exists option} -body {
set value foo
info exists value
} -cleanup {unset value} -result 1
test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body {
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
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}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
proc reduce {frame} {
| > > | < < > | < | < < | | | > > < < | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
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}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
proc reduce {frame} {
set cmd [dict get $frame cmd]
if {[regexp \n $cmd]} {
dict set frame cmd \
[string range [lindex [split $cmd \n] 0] 0 end-4]
}
if {[dict exists $frame file]} {
dict set frame file \
[file tail [dict get $frame file]]
}
return $frame
}
proc subinterp {} { interp create sub ; interp debug sub -frame 1;
interp eval sub [list proc reduce [info args reduce] [info body reduce]]
}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
lappend res [list $level [reduce [info frame $level]]]
incr level -1
}
return $res
}
test info-22.0 {info frame, levels} {!singleTestInterp} {
info frame
} 7
test info-22.1 {info frame, bad level relative} {!singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame -8} msg
set msg
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
reduce [info frame 1]
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
| | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
reduce [info frame 1]
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
test info-23.0.0 {eval'd info frame} {!singleTestInterp} {
eval {info frame}
} 8
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
set script {info frame 0}
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
| | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
set script {info frame 0}
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
| | | 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 |
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c}
# -------------------------------------------------------------------------
# 6 cases.
## DV. direct-var - unchanged
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
| | | | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 |
test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
set script {
set y DPV
etrace
}
join [lrange [control y $script] 0 3] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}
# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# literal sharing
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
} -cleanup {
rename abra {}
} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
| | | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
} -cleanup {
rename abra {}
} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
[info frame 0];# line 1457
}
return [reduce $xxx::res]
} {type source line 1457 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {
namespace eval xxx variable res \
[list [reduce [info frame 0]]];# line 1464
return $xxx::res
} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
set y DL.
etrace
}] 0 2] \n
}
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
| > > > > > > | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 |
set y DL.
etrace
}] 0 2] \n
}
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# This test at the end of this file _only_ to avoid disturbing above line
# numbers. It _belongs_ after info-9.12
test info-9.13 {info level option, value in global context} -body {
uplevel #0 {info level 2}
} -returnCodes error -result {bad level "2"}
# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
|
Changes to pkgs/msgcat/tests/interp.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# 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 testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source 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}
foreach i [interp slaves] {
interp delete $i
}
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
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: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}
foreach i [interp slaves] {
interp delete $i
}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/io.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
# 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}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
| > > > > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
# 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}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/ioCmd.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
| > > > | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/ioTrans.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
| > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# testchannel cut|splice Both needed to test the reflection in threads.
# thread::send
#----------------------------------------------------------------------
# ### ### ### ######### ######### #########
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
lappend res [set c [chan push [tempchan] foo]]
rename foo {}
lappend res [file channels file*]
lappend res [file channels rt*]
lappend res [catch {close $c} msg] $msg
lappend res [file channels file*]
lappend res [file channels rt*]
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return
}
lappend res [set c [chan push [tempchan] foo]]
close $c
# Close deleted the channel.
lappend res [file channels rt*]
# Channel destruction does not kill handler command!
lappend res [info command foo]
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code error 5
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
# Channel is gone despite error.
lappend res [file channels rt*]
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
error FOO
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg $::errorInfo
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return SOMETHING
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 3
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 4
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
set res {}
} -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -level 5 -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg opt] $msg
noteOpts $opt
} -match glob -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
| > > > > > > > > > > | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
lappend res [set c [chan push [tempchan] foo]]
rename foo {}
lappend res [file channels file*]
lappend res [file channels rt*]
lappend res [catch {close $c} msg] $msg
lappend res [file channels file*]
lappend res [file channels rt*]
} -cleanup {
tempdone
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return
}
lappend res [set c [chan push [tempchan] foo]]
close $c
# Close deleted the channel.
lappend res [file channels rt*]
# Channel destruction does not kill handler command!
lappend res [info command foo]
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code error 5
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
# Channel is gone despite error.
lappend res [file channels rt*]
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
error FOO
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg $::errorInfo
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return SOMETHING
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 3
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 4
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
set res {}
} -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -level 5 -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg opt] $msg
noteOpts $opt
} -match glob -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
# ### ### ### ######### ######### #########
| > > | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -cleanup {
tempdone
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
# ### ### ### ######### ######### #########
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/iogt.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
| > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/lindex.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
list [catch {testevalex lindex} result] $result
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
list [catch {testevalex lindex} result] $result
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/link.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/listObj.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
} {}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
} {}
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
test listobj-11.1 {bug 3598580} {
testobj bug3598580
} 123
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/load.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
| | | | | > > > > > > | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
test load-1.2 {basic errors} {} {
list [catch {load a b c d} msg] $msg
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
test load-1.3 {basic errors} {} {
list [catch {load a b foobar} msg] $msg
} {1 {could not find interpreter "foobar"}}
test load-1.4 {basic errors} {} {
list [catch {load -global {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.5 {basic errors} {} {
list [catch {load -lazy {} {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.6 {basic errors} {} {
list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}
test load-1.7 {basic errors} {} {
list [catch {load -abc foo} msg] $msg
} "1 {bad option \"-abc\": must be -global, -lazy, or --}"
test load-1.8 {basic errors} {} {
list [catch {load -global} msg] $msg
} "1 {couldn't figure out package name for -global}"
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
load -global [file join $testDir pkga$ext]
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load -lazy [file join $testDir pkgb$ext] pKgB child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
| | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
load -global [file join $testDir pkga$ext] pkga
load {} pkga x
set result [info loaded x]
interp delete x
set result
} [list [list [file join $testDir pkga$ext] Pkga]]
# On some platforms, like SunOS 4.1.3, these tests can't be run because
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
| | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}]
interp delete child
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
-constraints {teststaticpkg} \
-setup {
interp create child1
interp create child2
load {} Tcltest child1
load {} Tcltest child2
} \
-body {
child1 eval { teststaticpkg Loadninepointone 0 1 }
child2 eval { teststaticpkg Loadninepointone 0 1 }
list \
[child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} \
-match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \
-cleanup { interp delete child1 ; interp delete child2 }
test load-10.1 {load from vfs} \
-constraints [list $dll $loaded testsimplefilesystem] \
-setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \
-body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
-result {0 {}} \
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/lrange.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# 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::*
}
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# 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::*
}
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
test lrange-1.3 {range of list elements} {
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
# emacs highlighting bug workaround --> "
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-3.1 {Bug 3588366: end-offsets before start} {
apply {l {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/lset.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
set noRead {}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
set noRead {}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/misc.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
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])
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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]]
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])
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/msgcat.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
| | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
if {[catch {package require msgcat 1.5.0}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test."
return
}
namespace eval ::msgcat::test {
namespace import ::msgcat::*
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
|
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
| > > > > > > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
if {([info sharedlibextension] == ".dll")
&& ![catch {package require registry}]} {
# Windows and Cygwin have other ways to determine the
# locale when the environment variables are missing
# and the registry package is present
continue
}
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 613 614 615 616 617 618 |
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
cleanupTests
}
namespace delete ::msgcat::test
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
# Tests msgcat-8.*: [mcflset]
set msgdir1 [makeDirectory msgdir1]
makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1
test msgcat-8.1 {mcflset} -setup {
variable locale [mclocale]
mclocale l1
mcload $msgdir1
} -cleanup {
mclocale $locale
} -body {
mc k1
} -result v1
removeFile l1.msg $msgdir1
removeDirectory msgdir1
set msgdir2 [makeDirectory msgdir2]
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3
# chained mcload
test msgcat-8.2 {mcflset} -setup {
variable locale [mclocale]
mclocale l2
mcload $msgdir2
} -cleanup {
mclocale $locale
} -body {
return [mc k2][mc k3]
} -result v2v3
removeFile l2.msg $msgdir2
removeDirectory msgdir2
removeDirectory msgdir3
cleanupTests
}
namespace delete ::msgcat::test
return
|
Changes to pkgs/msgcat/tests/namespace.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# 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::*
testConstraint memory [llength [info commands memory]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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::*
testConstraint memory [llength [info commands memory]]
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/notify.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/nre.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
| < < | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-1.2 {self-recursive lambdas} -setup {
set a [list i [makebody {apply $::a $i}]]
} -body {
setabs
apply $a 0
} -cleanup {
unset a
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-1.3 {mutually recursive procs and lambdas} -setup {
proc a i {
apply $::b [incr i]
}
set b [list i [makebody {a $i}]]
} -body {
setabs
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
::foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
| | < | < | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
::foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
} -result {{0 2 2 2} 0}
test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
}
proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
} -body {
foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
} -result {{0 2 2 2} 0}
test nre-6.1 {[uplevel] is not recursive} -setup {
proc a i [makebody {uplevel 1 [list a $i]}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-6.2 {[uplevel] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
} -body {
a 0
} -cleanup {
rename a {}
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
| < < < < < < < < < < < < < < < < < < | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
test nre-7.2 {[if] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.3 {[while] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.4 {[for] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.5 {[foreach] is not recursive} -setup {
#
# Enable once [foreach] is NR-enabled
#
setabs
proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
test nre-7.6 {[eval] is not recursive} -setup {
proc a i [makebody {eval [list a $i]}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
test nre-7.7 {[eval] is not recursive} -setup {
proc a i [makebody {eval "a $i"}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
proc foo args {}
foo
coroutine bar apply {{} {
yield
proc foo args {return ok}
while 1 {
yield [incr i]
foo
}
}}
} -body {
# if switching to plain eval is not nre aware, this will cause a "cannot
# yield" error
list [bar] [bar] [bar]
} -cleanup {
rename bar {}
rename foo {}
} -result {1 2 3}
test nre-8.1 {nre and {*}} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the TEBCdataPtr. This crashes on failure.
proc inner {} {
set long [lrepeat 1000000 1]
list {*}$long
}
proc outer {} inner
lrange [outer] 0 2
} -cleanup {
rename inner {}
rename outer {}
} -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
# done properly.
proc nop {} {}
proc crash {} {
foreach val [list {*}[lrepeat 100000 x]] {
nop
}
}
crash
} -cleanup {
rename nop {}
rename crash {}
}
#
# Basic TclOO tests
#
test nre-oo.1 {really deep calls in oo - direct} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {foo bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {[self] bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.3 {really deep calls in oo - private calls} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {my bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.4 {really deep calls in oo - overriding} -setup {
oo::class create foo {
method bar i [makebody {my bar $i}]
}
oo::class create boo {
superclass foo
method bar i [makebody {next $i}]
}
} -body {
setabs
[boo new] bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.5 {really deep calls in oo - forwards} -setup {
oo::object create foo
set body [makebody {my boo $i}]
oo::objdefine foo "
method bar i {$body}
forward boo ::foo bar
"
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 2 1 1} 0}
#
# NASTY BUG found by tcllib's interp package
#
test nre-X.1 {eval in wrong interp} -setup {
set i [interp create]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/obj.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/oo.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2012 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/ooNext2.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | < < | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/parse.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
| > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
cleanupTests
}
namespace delete ::tcl::test::parse
return
| > > > > > > > > | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
test parse-21.0 {Bug 1884496} testevent {
set ::script {set a [p]; return -level 0 $a}
proc ::p {} {string first s $::script}
testevent queue a head $::script
update
} {}
cleanupTests
}
namespace delete ::tcl::test::parse
return
|
Changes to pkgs/msgcat/tests/parseExpr.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/parseOld.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# 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]]
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/platform.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/reg.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/registry.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
| | < < < | | > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::regver [package require registry 1.3.0]
}]} {
testConstraint reg 1
}
}
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
} {1.3.0}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
| | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} [string repeat x 16383]
test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/rename.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/resolver.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/result.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/set.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/socket.test.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | # 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::* # Some tests require the Thread package or exec command | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
# 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::*
# 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]]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
proc randport {} { expr {int(rand()*16383+49152)} }
# Test the latency of tcp connections over the loopback interface. Some OSes
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/string.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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 testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 |
test string-18.10 {string trim} {
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} {
| | | | | | | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 |
test string-18.10 {string trim} {
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
} ABC\u1361
test string-19.1 {string trimleft} {
list [catch {string trimleft} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
test string-19.2 {string trimleft} {
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
} \u1361ABC
test string-20.1 {string trimright errors} {
list [catch {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, 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 "
} { XYZ}
test string-20.4 {string trimright} {
string trimright " "
} {}
test string-20.5 {string trimright} {
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
} ABC\u1361
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"}}
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 |
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 {
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 {
tcl::prefix match -error str1 str2
| | | | 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 |
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 {
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 {
tcl::prefix match -error str1 str2
} -returnCodes 1 -result {missing value for -error}
test string-26.4 {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
} -returnCodes 1 -result {missing value for -message}
test string-26.5 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
test string-26.6 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/stringComp.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
| > > > | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# 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] != {}}]
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, 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
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
[string match *a*l*\u0000*cba* $longString] \
[string match *===* $longString]
}
foo
} {0 1 1 1 0 0}
## string range
| > > > > | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
[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
## not yet bc
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 | ## not yet bc ## string trim* ## not yet bc ## string word* ## not yet bc | | > > > > | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
## not yet bc
## string trim*
## not yet bc
## string word*
## not yet bc
# cleanup
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to pkgs/msgcat/tests/stringObj.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/tailcall.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/thread.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
# Some tests require the Thread package
| > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
# Some tests require the Thread package
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# Some tests may not work under valgrind
testConstraint notValgrind [expr {![testConstraint valgrind]}]
set threadSuperKillScript {
rename catch ""
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
while {[set x [testthread event]]} {
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
while {[set x [testthread event]]} {
#puts "WARNING: drained $x event(s) on main thread"
}
}
testthread errorproc ThreadError
set mainThread [testthread id]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/trace.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc getbytes {} {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc getbytes {} {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/unixFCmd.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/unixFile.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/unixNotfy.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
| | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# 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
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/unload.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/upvar.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/utf.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/util.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
# Big test for correct ordering of data in [expr]
| > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# 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]]
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/var.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
| > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/winDde.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
| > > > | < < < | > | < | < < > < | < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::ddever [package require dde 1.4.0]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
}
# -------------------------------------------------------------------------
# Setup a script for a test server
#
set scriptName [makeFile {} script1.tcl]
proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
| > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
} {1.4.0}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1 ""
dde execute -async TclEval self [list set \xe1 foo]
update
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
| | | | | | | | | | | | | > > > > > > > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1 ""
dde execute -async TclEval self [list set \xe1 foo]
update
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request TclEval self \xe1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
set \xe1 ""
dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf8} -constraints dde -body {
set \xe1 "not set"
dde execute TclEval self "set \xe1 \xc4"
scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints dde -body {
set \xe1 "not set"
dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
scan [set \xe1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke TclEval self \xe1 \xc4
dde request TclEval self \xe1
} -result \xc4
test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke -binary TclEval self \xe1 \xc3\x84\x00
dde request TclEval self \xe1
} -result \xc4
# -------------------------------------------------------------------------
test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.1
set child [createChildProcess $name]
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
| | | | | | | | > > > > > > > > > > | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
dde execute TclEval $name [list set \xe1 foo]
set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
set \xe1 [dde eval $name set \xe1 foo]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
set \xe1 ""
set name ch\xEDld-4.5
set child [createChildProcess $name]
dde poke TclEval $name \xe1 foo
set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
# -------------------------------------------------------------------------
test winDde-5.1 {check for bad arguments} -constraints dde -body {
dde execute "" "" "" ""
} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
test winDde-5.2 {check for bad arguments} -constraints dde -body {
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/winFCmd.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/winFile.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace import -force ::tcltest::*
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
testConstraint win2000 0
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
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"}]
}
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/winNotify.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
after 1000 { set done 1 }
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
after 1000 { set done 1 }
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/winPipe.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
| > > > > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
testConstraint testexcept [llength [info commands testexcept]]
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
| | > | > | > | > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}
set path(nothing) [makeFile {} nothing]
close [open $path(nothing) w]
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/winTime.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
|
| ︙ | ︙ |
Changes to pkgs/msgcat/tests/zlib.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # 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. | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
# 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 zlib [llength [info commands zlib]]
test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
zlib
} -result {wrong # args: should be "zlib command arg ?...?"}
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
test zlib-1.3 {zlib basics} -constraints zlib -body {
zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
package present zlib
} -result 2.0
test zlib-2.1 {zlib compress/decompress} zlib {
zlib decompress [zlib compress abcdefghijklm]
} abcdefghijklm
test zlib-3.1 {zlib deflate/inflate} zlib {
zlib inflate [zlib deflate abcdefghijklm]
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
set s [zlib stream compress]
} -body {
$s ?
} -cleanup {
$s close
| | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
set s [zlib stream compress]
} -body {
$s ?
} -cleanup {
$s close
} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset}
test zlib-7.1 {zlib stream} zlib {
set s [zlib stream compress]
$s put -finalize abcdeEDCBA
set data [$s get]
set result [list [$s get] [format %x [$s checksum]]]
$s close
lappend result [zlib decompress $data]
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
after 250 {lappend ::res MIDDLE}
vwait ::done
set ::res
} -cleanup {
catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
set file [makeFile {} test.gz]
set f [open $sfile wb]
puts -nonewline $f [zlib gzip [string repeat a 81920]]
close $f
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
after 250 {lappend ::res MIDDLE}
vwait ::done
set ::res
} -cleanup {
catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-8.6 {transformation and fconfigure} -setup {
set file [makeFile {} test.z]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
test zlib-8.7 {transformation and fconfigure} -setup {
set file [makeFile {} test.gz]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
# Input is headers from fetching SPDY draft
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
test zlib-8.8 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib decompress $compressed} err opt
list [string length [zlib compress $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode] [zlib adler32 $spdyDict]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
test zlib-8.9 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
set result [fconfigure $outSide -checksum]
chan pop $outSide
$strm put -dictionary $spdyDict [read $inSide]
lappend result [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {3064818174 358 358}
test zlib-8.10 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib inflate $compressed} err opt
list [string length [zlib deflate $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {254 212 {data error} {TCL ZLIB DATA}}
test zlib-8.11 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream inflate]
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
$strm put -dictionary $spdyDict [read $inSide]
list [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.12 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide
fconfigure $outSide -blocking 0 -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]] \
[fconfigure $inSide -checksum]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.13 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]] \
[fconfigure $inSide -checksum]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.14 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide
fconfigure $outSide -blocking 0 -buffering none -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.15 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -buffering none -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
set file [makeFile {} test.gz]
set f [open $sfile wb]
puts -nonewline $f [zlib gzip [string repeat a 81920]]
close $f
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
close $f
set d [zlib gunzip $d -header h]
list [regexp -all "hello" $d] [dict get $h filename] \
[string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 /foo/bar 0}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
close $f
set d [zlib gunzip $d -header h]
list [regexp -all "hello" $d] [dict get $h filename] \
[string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 /foo/bar 0}
test zlib-11.3 {Bug 3595576 variant} -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \
[string repeat "hello" 1000]
close $f
set f [open $file rb]
set d [read $f]
close $f
zlib gunzip $d -header noSuchNs::foo
} -cleanup {
removeFile $file
} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Added pkgs/package.list.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# This file contains the mapping of directory names to package names for
# documentation purposes. Each non-blank non-comment line is a two-element
# list that says a possible name of directory (multiple lines may be needed
# because of capitalization issues) and the documentation name of the package
# to match. Pseudo-numeric suffixes are interpreted as version numbers.
# [incr Tcl]
itcl {[incr Tcl]}
Itcl {[incr Tcl]}
# SQLite
sqlite SQLite
# Thread
Thread Thread
thread Thread
# Tcl Database Connectivity
tdbc TDBC
Tdbc TDBC
TDBC TDBC
# Drivers for TDBC
tdbcmysql tdbc::mysql
tdbcodbc tdbc::odbc
tdbcpostgres tdbc::postgres
tdbcsqlite3 tdbc::sqlite3
|
Changes to tests/assocd.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
} ""
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
} ""
|
| ︙ | ︙ |
Changes to tests/async.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
|
| ︙ | ︙ |
Changes to tests/basic.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#
# 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::*
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#
# 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
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
|
| ︙ | ︙ |
Changes to tests/binary.test.
| ︙ | ︙ | |||
2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
test binary-73.23 {binary decode base64} -body {
set r [binary decode base64 YWJj]
list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
string length [binary decode base64 " "]
} -result 0
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
| > > > > > > > > > > > > > > > > > > > > > | 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 |
test binary-73.23 {binary decode base64} -body {
set r [binary decode base64 YWJj]
list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
string length [binary decode base64 " "]
} -result 0
test binary-73.25 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==\n]]] $r
} -result {1 X}
test binary-73.26 {binary decode base64} -body {
list [string length [set r [binary decode base64 WFk=\n]]] $r
} -result {2 XY}
test binary-73.27 {binary decode base64} -body {
list [string length [set r [binary decode base64 WFla\n]]] $r
} -result {3 XYZ}
test binary-73.28 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WA==\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {86)C}
|
| ︙ | ︙ |
Changes to tests/chan.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
chan configure stdout -eofchar [list \x27 {}]
} -returnCodes ok -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
chan configure stdout -eofchar [list \x27 {}]
} -returnCodes ok -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
test chan-6.1 {chan command: eof subcommand} -body {
chan eof foo bar
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
| > > > | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
variable f
variable i
variable n
variable v
variable msg
variable expected
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport 0
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
|
| ︙ | ︙ |
Changes to tests/clock.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
| < < | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
package require registry
}]} {
namespace eval ::tcl::clock {variable NoRegistry {}}
}
}
package require msgcat 1.4
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
([string index $tcl_platform(osVersion) 0] >= 5
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
([string index $tcl_platform(osVersion) 0] >= 5
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch foo bar baz spaz
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd foo bar
} -result {wrong # args: should be "cd ?dirName?"}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} -setup {
file delete -force $foodir
| > > > > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch foo bar baz spaz
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.4 {Bug 3595576} {
catch {catch {} -> noSuchNs::var}
} 1
test cmdAH-1.5 {Bug 3595576} {
catch {catch error -> noSuchNs::var}
} 1
test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body {
cd foo bar
} -result {wrong # args: should be "cd ?dirName?"}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} -setup {
file delete -force $foodir
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
} -constraints testobj -body {
lreverse [K $y [unset y]]
lindex $x 0
} -cleanup {
unset -nocomplain x y
rename K {}
} -result 1
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
namespace eval my {namespace eval tcl {namespace eval mathfunc {
proc demo x {return 42}
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/cmdInfo.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
|
| ︙ | ︙ |
Changes to tests/compExpr-old.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
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]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to tests/compExpr.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Constrain memory leak tests
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
}
# Constrain memory leak tests
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # # 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::* testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. | > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # # 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 catch [list package require -exact Tcltest [info patchlevel]] testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. |
| ︙ | ︙ |
Changes to tests/coroutine.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
|
| ︙ | ︙ |
Changes to tests/dcall.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
testdcall
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
testdcall
|
| ︙ | ︙ |
Changes to tests/dict.test.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
test dict-3.3 {dict get command} {dict get {a b c d} c} d
test dict-3.4 {dict get command} -returnCodes error -body {
dict get {a b c d} b
} -result {key "b" not known in dictionary}
| > > > > > > > > > > > > > > > > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
} -result {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
} {{#} #comment}
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
test dict-2.9 {dict create command: compilation} {
apply {{} {dict create [format a] b}}
} {a b}
test dict-2.10 {dict create command: compilation} {
apply {{} {dict create [format a] b c d}}
} {a b c d}
test dict-2.11 {dict create command: compilation} {
apply {{} {dict create [format a] b c d a x}}
} {a x c d}
test dict-2.12 {dict create command: non-compilation} {
dict create [format a] b
} {a b}
test dict-2.13 {dict create command: non-compilation} {
dict create [format a] b c d
} {a b c d}
test dict-2.14 {dict create command: non-compilation} {
dict create [format a] b c d a x
} {a x c d}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
test dict-3.3 {dict get command} {dict get {a b c d} c} d
test dict-3.4 {dict get command} -returnCodes error -body {
dict get {a b c d} b
} -result {key "b" not known in dictionary}
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 784 785 786 787 788 789 790 |
unset -nocomplain dictVar
} -body {
set dictVar(block) {}
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {can't set "dictVar": variable is array}
test dict-17.1 {dict filter command: key} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict filter $dictVar key a2
} -cleanup {
unset dictVar
} -result {a2 b}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
unset -nocomplain dictVar
} -body {
set dictVar(block) {}
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {can't set "dictVar": variable is array}
# Now test with an LVT present (i.e., the bytecoded version).
test dict-16.10 {dict unset command} -body {
apply {{} {
set dictVar {a b c d}
dict unset dictVar a
}}
} -result {c d}
test dict-16.11 {dict unset command} -body {
apply {{} {
set dictVar {a b c d}
dict unset dictVar c
}}
} -result {a b}
test dict-16.12 {dict unset command} -body {
apply {{} {
set dictVar {a b}
dict unset dictVar c
}}
} -result {a b}
test dict-16.13 {dict unset command} -body {
apply {{} {
set dictVar {a {b c d e}}
dict unset dictVar a b
}}
} -result {a {d e}}
test dict-16.14 {dict unset command} -returnCodes error -body {
apply {{} {
set dictVar a
dict unset dictVar a
}}
} -result {missing value to go with key}
test dict-16.15 {dict unset command} -returnCodes error -body {
apply {{} {
set dictVar {a b}
dict unset dictVar c d
}}
} -result {key "c" not known in dictionary}
test dict-16.16 {dict unset command} -body {
apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}}
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
apply {{} {dict unset dictVar}}
} -result {wrong # args: should be "dict unset varName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
apply {{} {
set dictVar(block) {}
dict unset dictVar a
}}
} -returnCodes error -result {can't set "dictVar": variable is array}
test dict-17.1 {dict filter command: key} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict filter $dictVar key a2
} -cleanup {
unset dictVar
} -result {a2 b}
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
} {a x c y}
test dict-20.9 {dict merge command} {
dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 |
} {a x c y}
test dict-20.9 {dict merge command} {
dict merge {a b c d} {c y a x}
} {a x c y}
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
test dict-20.11 {dict merge command} {
apply {{} {dict merge}}
} {}
test dict-20.12 {dict merge command} {
apply {{} {dict merge {a b c d e f}}}
} {a b c d e f}
test dict-20.13 {dict merge command} -body {
apply {{} {dict merge {a b c d e}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.14 {dict merge command} {
apply {{} {dict merge {a b c d} {e f g h}}}
} {a b c d e f g h}
test dict-20.15 {dict merge command} -body {
apply {{} {dict merge {a b c d e} {e f g h}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.16 {dict merge command} -body {
apply {{} {dict merge {a b c d} {e f g h i}}}
} -result {missing value to go with key} -returnCodes error
test dict-20.17 {dict merge command} {
apply {{} {dict merge {a b c d e f} {e x g h}}}
} {a b c d e x g h}
test dict-20.18 {dict merge command} {
apply {{} {dict merge {a b c d} {a x c y}}}
} {a x c y}
test dict-20.19 {dict merge command} {
apply {{} {dict merge {a b c d} {c y a x}}}
} {a x c y}
test dict-20.20 {dict merge command} {
apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 |
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
dict map
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
dict map x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
dict map x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
dict map x x x x
} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
dict map x x x
} -result {must have exactly two variable names}
test dict-24.6 {dict map command: syntax} -returnCodes error -body {
dict map {x x x} x x
} -result {must have exactly two variable names}
test dict-24.7 {dict map command: syntax} -returnCodes error -body {
dict map "\{x" x x
} -result {unmatched open brace in list}
test dict-24.8 {dict map command} -setup {
set values {}
set keys {}
} -body {
# This test confirms that [dict keys], [dict values] and [dict map]
# all traverse a dictionary in the same order.
set dictv {a A b B c C}
dict map {k v} $dictv {
lappend keys $k
lappend values $v
}
set result [expr {
$keys eq [dict keys $dictv] && $values eq [dict values $dictv]
}]
expr {$result ? "YES" : [list "NO" $dictv $keys $values]}
} -cleanup {
unset result keys values k v dictv
} -result YES
test dict-24.9 {dict map command} {
dict map {k v} {} {
error "unexpected execution of 'dict map' body"
}
} {}
test dict-24.10 {dict map command: script results} -body {
set times 0
dict map {k v} {a a b b} {
incr times
continue
error "shouldn't get here"
}
return $times
} -cleanup {
unset times k v
} -result 2
test dict-24.11 {dict map command: script results} -body {
set times 0
dict map {k v} {a a b b} {
incr times
break
error "shouldn't get here"
}
return $times
} -cleanup {
unset times k v
} -result 1
test dict-24.12 {dict map command: script results} -body {
set times 0
list [catch {
dict map {k v} {a a b b} {
incr times
error test
}
} msg] $msg $times $::errorInfo
} -cleanup {
unset times k v msg
} -result {1 test 1 {test
while executing
"error test"
("dict map" body line 3)
invoked from within
"dict map {k v} {a a b b} {
incr times
error test
}"}}
test dict-24.13 {dict map command: script results} {
apply {{} {
dict map {k v} {a b} {
return ok,$k,$v
error "skipped return completely"
}
error "return didn't go far enough"
}}
} ok,a,b
test dict-24.14 {dict map command: handle representation loss} -setup {
set keys {}
set values {}
} -body {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[llength $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values]
} -cleanup {
unset dictVar keys values k v
} -result {4 {a c e g} {b d f h}}
test dict-24.14a {dict map command: handle representation loss} -body {
apply {{} {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[llength $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values]
}}
} -result {4 {a c e g} {b d f h}}
test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup {
unset -nocomplain accum
array set accum {}
} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict map {k v} $dictVar {
append accum($k) $v,
}
set result [lsort [array names accum]]
lappend result :
foreach k $result {
catch {lappend result $accum($k)}
}
return $result
} -cleanup {
unset dictVar k v result accum
} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,}
test dict-24.16 {dict map command in compilation context} {
apply {{} {
set res {x x x x x x}
dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} {
lset res $v $k
continue
}
return $res
}}
} {a b c d e f}
test dict-24.17 {dict map command in compilation context} {
# Bug 1379349 (dict for)
apply {{} {
set d [dict create a 1] ;# Dict must be unshared!
dict map {k v} $d {
dict set d $k 0 ;# Any modification will do
}
return $d
}}
} {a 0}
test dict-24.17a {dict map command in compilation context} {
# Bug 1379349 (dict for)
apply {{} {
set d [dict create a 1] ;# Dict must be unshared!
dict map {k v} $d {
dict set d $k 0 ;# Any modification will do
}
}}
} {a {a 0}}
test dict-24.18 {dict map command in compilation context} {
# Bug 1382528 (dict for)
apply {{} {
dict map {k v} {} {} ;# Note empty dict
catch { error foo } ;# Note compiled [catch]
}}
} 1
test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body {
di[list]ct map {k v} x {}
} -returnCodes 1 -result {missing value to go with key}
test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} {
apply {{x y args} {
dict map {a b} $x {}
concat "c=$y,$args"
}} {} 1 2 3
} {c=1,2 3}
proc linenumber {} {
dict get [info frame -1] line
}
test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} {
apply {{} {apply {n {
set e {}
set k {}
dict map {a b} {c {d {e {f g}}}} {
::tcl::dict::map {h i} $b {
dict update i e j {
::tcl::dict::update j f k {
return [expr {$n - [linenumber]}]
}
}
}
}
}} [linenumber]}}
} 5
test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug {
apply {{} {apply {n {
set e {}
set k {}
dict map {a {
b
}} {c {d {e {f g}}}} {
::tcl::dict::map {h {
i
}} ${
b
} {
dict update {
i
} e {
j
} {
::tcl::dict::update {
j
} f k {
return [expr {$n - [linenumber]}]
}
}
}
}
}} [linenumber]}}
} 5
rename linenumber {}
test dict-24.22 {dict map results (non-compiled)} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
return -level 0 "$k,$v"
}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.23 {dict map results (compiled)} {
apply {{} {
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
return -level 0 "$k,$v"
}
}}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.23a {dict map results (compiled)} {
apply {{list} {
dict map {k v} [dict map {k v} $list { list $v $k }] {
return -level 0 "$k,$v"
}
}} {a 1 b 2 c 3 d 4}
} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}}
test dict-24.24 {dict map with huge dict (non-compiled)} {
tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] {
expr { $k * $v }
}]
} 166666666600000
test dict-24.25 {dict map with huge dict (compiled)} {
apply {{n} {
tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] {
expr { $k * $v }
}]
}} 100000
} 166666666600000
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/dstring.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
testdstring free
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
testdstring free
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
package require tcltest 2
namespace eval ::tcl::test::encoding {
variable x
namespace import -force ::tcltest::*
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
variable x
lappend x "fromutf $args"
}
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
| > > > > > < | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
package require tcltest 2
namespace eval ::tcl::test::encoding {
variable x
namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
}
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
variable x
lappend x "fromutf $args"
}
proc runtests {} {
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
set old [encoding system]
} -constraints {testencoding} -body {
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
test encoding-24.1 {EscapeFreeProc on open channels} exec {
runInSubprocess {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
| | > | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
test encoding-24.1 {EscapeFreeProc on open channels} exec {
runInSubprocess {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab\u4e4e\u68d9g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}]
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
test encoding-27.1 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs ? ?
} -result {wrong # args: should be "encoding dirs ?dirList?"}
test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs "\{not a list"
} -result "expected directory list but got \"\{not a list\""
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/env.test.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
| | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
return [subst -novariables $s]
}
proc manglechar c {
return [format {\u%04x} [scan $c %c]]
}
set names [lsort [array names env]]
|
| ︙ | ︙ |
Changes to tests/event.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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::*
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 |
# file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
| > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
# file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
return $result
} {even 16
|
| ︙ | ︙ |
Changes to tests/exec.test.
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
set sysenc [encoding system]
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
| | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
set sysenc [encoding system]
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
regsub -all "\[\u007f-\uffff\]" $s \
{[apply {c {format {\u%04x} [scan $c %c]}} &]} s
return [subst -novariables $s]
}
} -constraints {exec} -body {
# If this fails, it may give back: "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
# If it does, this means that the UTF -> external conversion did not occur
# before writing out the temp file.
|
| ︙ | ︙ |
Changes to tests/execute.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
testConstraint testobj [expr {
| > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
testConstraint testobj [expr {
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
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
|
| ︙ | ︙ |
Changes to tests/expr.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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.
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::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.
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
# Don't know how to determine this constraint correctly
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
# Don't know how to determine this constraint correctly
|
| ︙ | ︙ |
Changes to tests/fileName.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {[string index $tcl_platform(osVersion) 0] < 5 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {[string index $tcl_platform(osVersion) 0] < 5 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
| | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
} "/ foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
} {foo bar}
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
| | | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
} "/a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} "/a/b"
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join a b
} {a/b}
test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
file join [lindex [glob ~] 0]
} [file join $env(HOME)]
set oldpwd [pwd]
set oldhome $env(HOME)
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
file join [lindex [glob ~] 0]
} [file join $env(HOME)]
set oldpwd [pwd]
set oldhome $env(HOME)
catch {cd [makeDirectory tcl[pid]]}
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
touch globTest/x1.c
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 |
} -result ~/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
} -result ~/sub/fileName-20.10
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
catch {removeDirectory tcl[pid]}
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result globPreResult}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/fileSystem.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
namespace import ::tcltest::*
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
cd [tcltest::temporaryDirectory]
| > > > > > > > > > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
namespace import ::tcltest::*
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
testConstraint loaddll 0
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::ddever [package require dde]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
set ::regver [package require registry]
set ::reglib [lindex [package ifneeded registry $::regver] 1]
testConstraint loaddll 1
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
cd [tcltest::temporaryDirectory]
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
set old [pwd]
} -constraints {win} -body {
set drv C:/
cd [lindex [glob -type d -dir $drv *] 0]
file norm [string range $drv 0 1]
} -cleanup {
cd $old
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
set old [pwd]
} -constraints {win} -body {
set drv C:/
cd [lindex [glob -type d -dir $drv *] 0]
file norm [string range $drv 0 1]
} -cleanup {
cd $old
} -match regexp -result {.*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
testPathEqual [file norm foo////bar] [file norm foo/bar]
} ok
test filesystem-1.41 {file normalisation with repeated separators} {win} {
testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]
} ok
test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
test filesystem-6.19 {empty file name} {file nativename ""} {}
test filesystem-6.20 {empty file name} {file normalize ""} {}
test filesystem-6.21 {empty file name} {file owned ""} 0
test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
| | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
test filesystem-6.19 {empty file name} {file nativename ""} {}
test filesystem-6.20 {empty file name} {file normalize ""} {}
test filesystem-6.21 {empty file name} {file owned ""} 0
test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
} -result {could not read link "": no such file or directory}
test filesystem-6.25 {empty file name} -returnCodes error -body {
file rename "" ""
} -result {error renaming "": no such file or directory}
test filesystem-6.26 {empty file name} {file rootname ""} {}
test filesystem-6.27 {empty file name} -returnCodes error -body {
file separator ""
} -result {unrecognised path}
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
| | | < | | | < | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::ddelib]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
load simplefs:/[file tail $::ddelib] dde
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads reg via a complex copy-to-temp operation
load simplefs:/[file tail $::reglib] Registry
unload simplefs:/[file tail $::reglib]
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
} -cleanup {
cd $dir
} -result ok
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup {
|
| ︙ | ︙ |
Changes to tests/foreach.test.
| ︙ | ︙ | |||
261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
# cleanup
catch {unset a}
catch {unset x}
catch {rename foo {}}
::tcltest::cleanupTests
return
| > > > > > > > > > | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
test foreach-11.1 {error then dereference loop var (dev bug)} {
catch { foreach a 0 b {1 2 3} { error x } }
set a
} 0
test foreach-11.2 {error then dereference loop var (dev bug)} {
catch { foreach a 0 b {1 2 3} { incr a $b; error x } }
set a
} 1
# cleanup
catch {unset a}
catch {unset x}
catch {rename foo {}}
::tcltest::cleanupTests
return
|
Changes to tests/format.test.
| ︙ | ︙ | |||
545 546 547 548 549 550 551 |
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
| < | < < | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
format %llx 0
} 0
test format-19.3 {Bug 2830354} {
string length [format %340f 0]
} 340
# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
set x [dict create a b c d]
format %s $x
# After this, obj in $x should be a dict with a non-NULL bytes field
tcl::unsupported::representation $x
} -match glob -result {value is a dict with *, string representation "*"}
# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/get.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
|
| ︙ | ︙ |
Changes to tests/http.test.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
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}
puts "Running httpd in thread $httpthread"
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
| > | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
} -match regexp -result {(?n)Accept \*/\*
Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
| > > > > > > > > > > > > > > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
} -match regexp -result {(?n)Accept \*/\*
Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
test http-3.29 "http::geturl $ipv6url" -body {
# We only want to see if the URL gets parsed correctly. This is
# the case if http::geturl succeeds or returns a socket related
# error. If the parsing is wrong, we'll get a parse error.
# It'd be better to separate the URL parser from http::geturl, so
# that it can be tested without also trying to make a connection.
set error [catch {http::geturl $ipv6url -validate 1} token]
if {$error && [string match "couldn't open socket: *" $token]} {
set error 0
}
set error
} -cleanup {
catch { http::cleanup $token }
} -result 0
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/indexObj.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
|
| ︙ | ︙ |
Changes to tests/info.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
| > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
| < | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
test info-6.11 {info default option} {
catch {namespace delete test_ns_info2}
namespace eval test_ns_info2 {
namespace import ::test_ns_info1::*
list [info default p x foo] $foo [info default q y bar] $bar
}
} {0 {} 1 27}
test info-7.1 {info exists option} -body {
set value foo
info exists value
} -cleanup {unset value} -result 1
test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body {
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
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}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
proc reduce {frame} {
| > > | < < > | < | < < | | | > > < < | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
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}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
proc reduce {frame} {
set cmd [dict get $frame cmd]
if {[regexp \n $cmd]} {
dict set frame cmd \
[string range [lindex [split $cmd \n] 0] 0 end-4]
}
if {[dict exists $frame file]} {
dict set frame file \
[file tail [dict get $frame file]]
}
return $frame
}
proc subinterp {} { interp create sub ; interp debug sub -frame 1;
interp eval sub [list proc reduce [info args reduce] [info body reduce]]
}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
lappend res [list $level [reduce [info frame $level]]]
incr level -1
}
return $res
}
test info-22.0 {info frame, levels} {!singleTestInterp} {
info frame
} 7
test info-22.1 {info frame, bad level relative} {!singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame -8} msg
set msg
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
reduce [info frame 1]
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
| | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
reduce [info frame -6]
} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
reduce [info frame 1]
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
test info-23.0.0 {eval'd info frame} {!singleTestInterp} {
eval {info frame}
} 8
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
set script {info frame 0}
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
| | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
set script {info frame 0}
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
| | | 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 |
c}
set cmd [list foreach $foo {x y} {
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c}
# -------------------------------------------------------------------------
# 6 cases.
## DV. direct-var - unchanged
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
| | | | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 |
test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
set script {
set y DPV
etrace
}
join [lrange [control y $script] 0 3] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}
# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
# literal sharing
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
} -cleanup {
rename abra {}
} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
| | | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
} -cleanup {
rename abra {}
} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
[info frame 0];# line 1457
}
return [reduce $xxx::res]
} {type source line 1457 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {
namespace eval xxx variable res \
[list [reduce [info frame 0]]];# line 1464
return $xxx::res
} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
set y DL.
etrace
}] 0 2] \n
}
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
| > > > > > > | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 |
set y DL.
etrace
}] 0 2] \n
}
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
# This test at the end of this file _only_ to avoid disturbing above line
# numbers. It _belongs_ after info-9.12
test info-9.13 {info level option, value in global context} -body {
uplevel #0 {info level 2}
} -returnCodes error -result {bad level "2"}
# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
|
Changes to tests/interp.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# 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 testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source 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}
foreach i [interp slaves] {
interp delete $i
}
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
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: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}
foreach i [interp slaves] {
interp delete $i
}
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
# 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}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
| > > > > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
# 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}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
| > > > | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
#----------------------------------------------------------------------
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
|
| ︙ | ︙ |
Changes to tests/ioTrans.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
| > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# testchannel cut|splice Both needed to test the reflection in threads.
# thread::send
#----------------------------------------------------------------------
# ### ### ### ######### ######### #########
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
lappend res [set c [chan push [tempchan] foo]]
rename foo {}
lappend res [file channels file*]
lappend res [file channels rt*]
lappend res [catch {close $c} msg] $msg
lappend res [file channels file*]
lappend res [file channels rt*]
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return
}
lappend res [set c [chan push [tempchan] foo]]
close $c
# Close deleted the channel.
lappend res [file channels rt*]
# Channel destruction does not kill handler command!
lappend res [info command foo]
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code error 5
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
# Channel is gone despite error.
lappend res [file channels rt*]
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
error FOO
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg $::errorInfo
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return SOMETHING
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 3
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 4
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
set res {}
} -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -level 5 -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg opt] $msg
noteOpts $opt
} -match glob -cleanup {
rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
| > > > > > > > > > > | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
lappend res [set c [chan push [tempchan] foo]]
rename foo {}
lappend res [file channels file*]
lappend res [file channels rt*]
lappend res [catch {close $c} msg] $msg
lappend res [file channels file*]
lappend res [file channels rt*]
} -cleanup {
tempdone
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return
}
lappend res [set c [chan push [tempchan] foo]]
close $c
# Close deleted the channel.
lappend res [file channels rt*]
# Channel destruction does not kill handler command!
lappend res [info command foo]
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code error 5
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
# Channel is gone despite error.
lappend res [file channels rt*]
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
error FOO
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg $::errorInfo
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return SOMETHING
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 3
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 4
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg] $msg
} -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
set res {}
} -body {
proc foo {args} {
lappend ::res $args
handle.initialize
return -level 5 -code 777 BANG
}
lappend res [set c [chan push [tempchan] foo]]
lappend res [catch {close $c} msg opt] $msg
noteOpts $opt
} -match glob -cleanup {
rename foo {}
tempdone
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
# ### ### ### ######### ######### #########
| > > | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -cleanup {
tempdone
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
# ### ### ### ######### ######### #########
|
| ︙ | ︙ |
Changes to tests/iogt.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
| > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
|
| ︙ | ︙ |
Changes to tests/lindex.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
list [catch {testevalex lindex} result] $result
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
list [catch {testevalex lindex} result] $result
|
| ︙ | ︙ |
Changes to tests/link.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
unset -nocomplain $i
}
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
|
| ︙ | ︙ |
Changes to tests/listObj.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
} {}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
} {}
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
[testlistobj get 1]
}
-cleanup {
testobj freeallvars
}
-result {{a b c d e} {} {a b c d e f}}
}
test listobj-11.1 {bug 3598580} {
testobj bug3598580
} 123
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Added tests/lmap.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
# Commands covered: lmap, continue, break
#
# 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-1997 Sun Microsystems, Inc.
# Copyright (c) 2011 Trevor Davel
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
unset -nocomplain a i x
# ----- Non-compiled operation -----------------------------------------------
# Basic "lmap" operation (non-compiled)
test lmap-1.1 {basic lmap tests} {
set a {}
lmap i {a b c d} {
set a [concat $a $i]
}
} {a {a b} {a b c} {a b c d}}
test lmap-1.2 {basic lmap tests} {
lmap i {a b {{c d} e} {123 {{x}}}} {
set i
}
} {a b {{c d} e} {123 {{x}}}}
test lmap-1.2a {basic lmap tests} {
lmap i {a b {{c d} e} {123 {{x}}}} {
return -level 0 $i
}
} {a b {{c d} e} {123 {{x}}}}
test lmap-1.4 {basic lmap tests} -returnCodes error -body {
lmap
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-1.6 {basic lmap tests} -returnCodes error -body {
lmap i
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-1.8 {basic lmap tests} -returnCodes error -body {
lmap i j
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-1.10 {basic lmap tests} -returnCodes error -body {
lmap i j k l
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-1.11 {basic lmap tests} {
lmap i {} {
set i
}
} {}
test lmap-1.12 {basic lmap tests} {
lmap i {} {
return -level 0 x
}
} {}
test lmap-1.13 {lmap errors} -returnCodes error -body {
lmap {{a}{b}} {1 2 3} {}
} -result {list element in braces followed by "{b}" instead of space}
test lmap-1.14 {lmap errors} -returnCodes error -body {
lmap a {{1 2}3} {}
} -result {list element in braces followed by "3" instead of space}
unset -nocomplain a
test lmap-1.15 {lmap errors} -setup {
unset -nocomplain a
} -body {
set a(0) 44
list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo
} -result {1 {can't set "a": variable is array} {can't set "a": variable is array
(setting lmap loop variable "a")
invoked from within
"lmap a {1 2 3} {}"}}
test lmap-1.16 {lmap errors} -returnCodes error -body {
lmap {} {} {}
} -result {lmap varlist is empty}
unset -nocomplain a
# Parallel "lmap" operation (non-compiled)
test lmap-2.1 {parallel lmap tests} {
lmap {a b} {1 2 3 4} {
list $b $a
}
} {{2 1} {4 3}}
test lmap-2.2 {parallel lmap tests} {
lmap {a b} {1 2 3 4 5} {
list $b $a
}
} {{2 1} {4 3} {{} 5}}
test lmap-2.3 {parallel lmap tests} {
lmap a {1 2 3} b {4 5 6} {
list $b $a
}
} {{4 1} {5 2} {6 3}}
test lmap-2.4 {parallel lmap tests} {
lmap a {1 2 3} b {4 5 6 7 8} {
list $b $a
}
} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
test lmap-2.5 {parallel lmap tests} {
lmap {a b} {a b A B aa bb} c {c C cc CC} {
list $a $b $c
}
} {{a b c} {A B C} {aa bb cc} {{} {} CC}}
test lmap-2.6 {parallel lmap tests} {
lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
list $a$b$c$d$e
}
} {11111 22222 33333}
test lmap-2.7 {parallel lmap tests} {
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
set x $a$b$c$d$e
}
} {{1111 2} 222 33 4}
test lmap-2.8 {parallel lmap tests} {
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
join [list $a $b $c $d $e] .
}
} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
test lmap-2.9 {lmap only sets vars if repeating loop} {
namespace eval ::lmap_test {
set rgb {65535 0 0}
lmap {r g b} [set rgb] {}
set ::x "r=$r, g=$g, b=$b"
}
namespace delete ::lmap_test
set x
} {r=65535, g=0, b=0}
test lmap-2.10 {lmap only supports local scalar variables} -setup {
unset -nocomplain a
} -body {
lmap {a(3)} {1 2 3 4} {set {a(3)}}
} -result {1 2 3 4}
unset -nocomplain a
# "lmap" with "continue" and "break" (non-compiled)
test lmap-3.1 {continue tests} {
lmap i {a b c d} {
if {[string compare $i "b"] == 0} continue
set i
}
} {a c d}
test lmap-3.2 {continue tests} {
set x 0
list [lmap i {a b c d} {
incr x
if {[string compare $i "b"] != 0} continue
set i
}] $x
} {b 4}
test lmap-3.3 {break tests} {
set x 0
list [lmap i {a b c d} {
incr x
if {[string compare $i "c"] == 0} break
set i
}] $x
} {{a b} 3}
# Check for bug similar to #406709
test lmap-3.4 {break tests} {
set a 1
lmap b b {list [concat a; break]; incr a}
incr a
} {2}
# ----- Compiled operation ---------------------------------------------------
# Basic "lmap" operation (compiled)
test lmap-4.1 {basic lmap tests} {
apply {{} {
set a {}
lmap i {a b c d} {
set a [concat $a $i]
}
}}
} {a {a b} {a b c} {a b c d}}
test lmap-4.2 {basic lmap tests} {
apply {{} {
lmap i {a b {{c d} e} {123 {{x}}}} {
set i
}
}}
} {a b {{c d} e} {123 {{x}}}}
test lmap-4.2a {basic lmap tests} {
apply {{} {
lmap i {a b {{c d} e} {123 {{x}}}} {
return -level 0 $i
}
}}
} {a b {{c d} e} {123 {{x}}}}
test lmap-4.4 {basic lmap tests} -returnCodes error -body {
apply {{} { lmap }}
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-4.6 {basic lmap tests} -returnCodes error -body {
apply {{} { lmap i }}
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-4.8 {basic lmap tests} -returnCodes error -body {
apply {{} { lmap i j }}
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-4.10 {basic lmap tests} -returnCodes error -body {
apply {{} { lmap i j k l }}
} -result {wrong # args: should be "lmap varList list ?varList list ...? command"}
test lmap-4.11 {basic lmap tests} {
apply {{} { lmap i {} { set i } }}
} {}
test lmap-4.12 {basic lmap tests} {
apply {{} { lmap i {} { return -level 0 x } }}
} {}
test lmap-4.13 {lmap errors} -returnCodes error -body {
apply {{} { lmap {{a}{b}} {1 2 3} {} }}
} -result {list element in braces followed by "{b}" instead of space}
test lmap-4.14 {lmap errors} -returnCodes error -body {
apply {{} { lmap a {{1 2}3} {} }}
} -result {list element in braces followed by "3" instead of space}
unset -nocomplain a
test lmap-4.15 {lmap errors} {
apply {{} {
set a(0) 44
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} {}"}}
test lmap-4.16 {lmap errors} -returnCodes error -body {
apply {{} {
lmap {} {} {}
}}
} -result {lmap varlist is empty}
unset -nocomplain a
# Parallel "lmap" operation (compiled)
test lmap-5.1 {parallel lmap tests} {
apply {{} {
lmap {a b} {1 2 3 4} {
list $b $a
}
}}
} {{2 1} {4 3}}
test lmap-5.2 {parallel lmap tests} {
apply {{} {
lmap {a b} {1 2 3 4 5} {
list $b $a
}
}}
} {{2 1} {4 3} {{} 5}}
test lmap-5.3 {parallel lmap tests} {
apply {{} {
lmap a {1 2 3} b {4 5 6} {
list $b $a
}
}}
} {{4 1} {5 2} {6 3}}
test lmap-5.4 {parallel lmap tests} {
apply {{} {
lmap a {1 2 3} b {4 5 6 7 8} {
list $b $a
}
}}
} {{4 1} {5 2} {6 3} {7 {}} {8 {}}}
test lmap-5.5 {parallel lmap tests} {
apply {{} {
lmap {a b} {a b A B aa bb} c {c C cc CC} {
list $a $b $c
}
}}
} {{a b c} {A B C} {aa bb cc} {{} {} CC}}
test lmap-5.6 {parallel lmap tests} {
apply {{} {
lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} {
list $a$b$c$d$e
}
}}
} {11111 22222 33333}
test lmap-5.7 {parallel lmap tests} {
apply {{} {
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
set x $a$b$c$d$e
}
}}
} {{1111 2} 222 33 4}
test lmap-5.8 {parallel lmap tests} {
apply {{} {
lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} {
join [list $a $b $c $d $e] .
}
}}
} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.}
test lmap-5.9 {lmap only sets vars if repeating loop} {
apply {{} {
set rgb {65535 0 0}
lmap {r g b} [set rgb] {}
return "r=$r, g=$g, b=$b"
}}
} {r=65535, g=0, b=0}
test lmap-5.10 {lmap only supports local scalar variables} {
apply {{} {
lmap {a(3)} {1 2 3 4} {set {a(3)}}
}}
} {1 2 3 4}
# "lmap" with "continue" and "break" (compiled)
test lmap-6.1 {continue tests} {
apply {{} {
lmap i {a b c d} {
if {[string compare $i "b"] == 0} continue
set i
}
}}
} {a c d}
test lmap-6.2 {continue tests} {
apply {{} {
list [lmap i {a b c d} {
incr x
if {[string compare $i "b"] != 0} continue
set i
}] $x
}}
} {b 4}
test lmap-6.3 {break tests} {
apply {{} {
list [lmap i {a b c d} {
incr x
if {[string compare $i "c"] == 0} break
set i
}] $x
}}
} {{a b} 3}
# Check for bug similar to #406709
test lmap-6.4 {break tests} {
apply {{} {
set a 1
lmap b b {list [concat a; break]; incr a}
incr a
}}
} {2}
# ----- Special cases and bugs -----------------------------------------------
test lmap-7.1 {compiled lmap backward jump works correctly} -setup {
unset -nocomplain x
} -body {
array set x {0 zero 1 one 2 two 3 three}
lsort [apply {{arrayName} {
upvar 1 $arrayName a
lmap member [array names a] {
list $member [set a($member)]
}
}} x]
} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}]
test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup {
unset -nocomplain x
} -body {
lmap {12.0} {a b c} {
set x 12.0
set x [expr $x + 1]
}
} -result {13.0 13.0 13.0}
# Test for incorrect "double evaluation" semantics
test lmap-7.3 {delayed substitution of body} {
apply {{} {
set a 0
lmap a [list 1 2 3] "
set x $a
"
return $x
}}
} {0}
# Related to "foreach" test for [Bug 1189274]; crash on failure
test lmap-7.4 {empty list handling} {
proc crash {} {
rename crash {}
set a "x y z"
set b ""
lmap aa $a bb $b { set x "aa = $aa bb = $bb" }
}
crash
} {{aa = x bb = } {aa = y bb = } {aa = z bb = }}
# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled
# version.
test lmap-7.5 {compiled empty var list} -returnCodes error -body {
proc foo {} {
lmap {} x {
error "reached body"
}
}
foo
} -cleanup {
catch {rename foo ""}
} -result {lmap varlist is empty}
test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup {
proc demo {} {
set vals {1 2 3 4}
trace add variable x write {string length $vals ;# }
lmap {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {2 4}
# Huge lists must not overflow the bytecode interpreter (development bug)
test lmap-7.7 {huge list non-compiled} {
set x [lmap a [lrepeat 1000000 x] { set b y$a }]
list $b [llength $x] [string length $x]
} {yx 1000000 2999999}
test lmap-7.8 {huge list compiled} {
set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000]
list $b [llength $x] [string length $x]
} {yx 1000000 2999999}
test lmap-7.9 {error then dereference loop var (dev bug)} {
catch { lmap a 0 b {1 2 3} { error x } }
set a
} 0
test lmap-7.9a {error then dereference loop var (dev bug)} {
catch { lmap a 0 b {1 2 3} { incr a $b; error x } }
set a
} 1
# ----- Coroutines -----------------------------------------------------------
test lmap-8.1 {lmap non-compiled with coroutines} -body {
coroutine coro apply {{} {
set values [yield [info coroutine]]
eval lmap i [list $values] {{ yield $i }}
}} ;# returns 'coro'
coro {a b c d e f} ;# -> a
coro 1 ;# -> b
coro 2 ;# -> c
coro 3 ;# -> d
coro 4 ;# -> e
coro 5 ;# -> f
list [coro 6] [info commands coro]
} -cleanup {
catch {rename coro ""}
} -result {{1 2 3 4 5 6} {}}
test lmap-8.2 {lmap compiled with coroutines} -body {
coroutine coro apply {{} {
set values [yield [info coroutine]]
lmap i $values { yield $i }
}} ;# returns 'coro'
coro {a b c d e f} ;# -> a
coro 1 ;# -> b
coro 2 ;# -> c
coro 3 ;# -> d
coro 4 ;# -> e
coro 5 ;# -> f
list [coro 6] [info commands coro]
} -cleanup {
catch {rename coro ""}
} -result {{1 2 3 4 5 6} {}}
# cleanup
unset -nocomplain a x
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/load.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
| | | | | > > > > > > | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
test load-1.2 {basic errors} {} {
list [catch {load a b c d} msg] $msg
} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}"
test load-1.3 {basic errors} {} {
list [catch {load a b foobar} msg] $msg
} {1 {could not find interpreter "foobar"}}
test load-1.4 {basic errors} {} {
list [catch {load -global {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.5 {basic errors} {} {
list [catch {load -lazy {} {}} msg] $msg
} {1 {must specify either file name or package name}}
test load-1.6 {basic errors} {} {
list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}
test load-1.7 {basic errors} {} {
list [catch {load -abc foo} msg] $msg
} "1 {bad option \"-abc\": must be -global, -lazy, or --}"
test load-1.8 {basic errors} {} {
list [catch {load -global} msg] $msg
} "1 {couldn't figure out package name for -global}"
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
load -global [file join $testDir pkga$ext]
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load -lazy [file join $testDir pkgb$ext] pKgB child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
| | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
load -global [file join $testDir pkga$ext] pkga
load {} pkga x
set result [info loaded x]
interp delete x
set result
} [list [list [file join $testDir pkga$ext] Pkga]]
# On some platforms, like SunOS 4.1.3, these tests can't be run because
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
| | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
list [info loaded {}] [info loaded child]
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}]
interp delete child
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
-constraints {teststaticpkg} \
-setup {
interp create child1
interp create child2
load {} Tcltest child1
load {} Tcltest child2
} \
-body {
child1 eval { teststaticpkg Loadninepointone 0 1 }
child2 eval { teststaticpkg Loadninepointone 0 1 }
list \
[child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} \
-match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \
-cleanup { interp delete child1 ; interp delete child2 }
test load-10.1 {load from vfs} \
-constraints [list $dll $loaded testsimplefilesystem] \
-setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \
-body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
-result {0 {}} \
|
| ︙ | ︙ |
Changes to tests/lrange.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# 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::*
}
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# 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::*
}
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
test lrange-1.3 {range of list elements} {
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
# emacs highlighting bug workaround --> "
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-3.1 {Bug 3588366: end-offsets before start} {
apply {l {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/lset.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
set noRead {}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
set noRead {}
|
| ︙ | ︙ |
Changes to tests/misc.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
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])
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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]]
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])
|
| ︙ | ︙ |
Changes to tests/msgcat.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
| | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
if {[catch {package require msgcat 1.5.0}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test."
return
}
namespace eval ::msgcat::test {
namespace import ::msgcat::*
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
|
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
| > > > > > > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
if {([info sharedlibextension] == ".dll")
&& ![catch {package require registry}]} {
# Windows and Cygwin have other ways to determine the
# locale when the environment variables are missing
# and the registry package is present
continue
}
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 613 614 615 616 617 618 |
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
cleanupTests
}
namespace delete ::msgcat::test
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
# Tests msgcat-8.*: [mcflset]
set msgdir1 [makeDirectory msgdir1]
makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1
test msgcat-8.1 {mcflset} -setup {
variable locale [mclocale]
mclocale l1
mcload $msgdir1
} -cleanup {
mclocale $locale
} -body {
mc k1
} -result v1
removeFile l1.msg $msgdir1
removeDirectory msgdir1
set msgdir2 [makeDirectory msgdir2]
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3
# chained mcload
test msgcat-8.2 {mcflset} -setup {
variable locale [mclocale]
mclocale l2
mcload $msgdir2
} -cleanup {
mclocale $locale
} -body {
return [mc k2][mc k3]
} -result v2v3
removeFile l2.msg $msgdir2
removeDirectory msgdir2
removeDirectory msgdir3
cleanupTests
}
namespace delete ::msgcat::test
return
|
Changes to tests/namespace.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# 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::*
testConstraint memory [llength [info commands memory]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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::*
testConstraint memory [llength [info commands memory]]
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ |
Changes to tests/notify.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
after 10 set done 1
|
| ︙ | ︙ |
Changes to tests/nre.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
| < < | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-1.2 {self-recursive lambdas} -setup {
set a [list i [makebody {apply $::a $i}]]
} -body {
setabs
apply $a 0
} -cleanup {
unset a
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-1.3 {mutually recursive procs and lambdas} -setup {
proc a i {
apply $::b [incr i]
}
set b [list i [makebody {a $i}]]
} -body {
setabs
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
::foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
| | < | < | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
::foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
} -result {{0 2 2 2} 0}
test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
}
proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
} -body {
foo::a 0
} -cleanup {
namespace delete ::foo
} -constraints {
testnrelevels
} -result {{0 2 2 2} 0}
test nre-6.1 {[uplevel] is not recursive} -setup {
proc a i [makebody {uplevel 1 [list a $i]}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-6.2 {[uplevel] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
} -body {
a 0
} -cleanup {
rename a {}
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
| < < < < < < < < < < < < < < < < < < | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
test nre-7.2 {[if] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.3 {[while] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.4 {[for] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
test nre-7.5 {[foreach] is not recursive} -setup {
#
# Enable once [foreach] is NR-enabled
#
setabs
proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}]
} -body {
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
test nre-7.6 {[eval] is not recursive} -setup {
proc a i [makebody {eval [list a $i]}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
test nre-7.7 {[eval] is not recursive} -setup {
proc a i [makebody {eval "a $i"}]
} -body {
setabs
a 0
} -cleanup {
rename a {}
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
proc foo args {}
foo
coroutine bar apply {{} {
yield
proc foo args {return ok}
while 1 {
yield [incr i]
foo
}
}}
} -body {
# if switching to plain eval is not nre aware, this will cause a "cannot
# yield" error
list [bar] [bar] [bar]
} -cleanup {
rename bar {}
rename foo {}
} -result {1 2 3}
test nre-8.1 {nre and {*}} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the TEBCdataPtr. This crashes on failure.
proc inner {} {
set long [lrepeat 1000000 1]
list {*}$long
}
proc outer {} inner
lrange [outer] 0 2
} -cleanup {
rename inner {}
rename outer {}
} -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
# done properly.
proc nop {} {}
proc crash {} {
foreach val [list {*}[lrepeat 100000 x]] {
nop
}
}
crash
} -cleanup {
rename nop {}
rename crash {}
}
#
# Basic TclOO tests
#
test nre-oo.1 {really deep calls in oo - direct} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {foo bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {[self] bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.3 {really deep calls in oo - private calls} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {my bar $i}]
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.4 {really deep calls in oo - overriding} -setup {
oo::class create foo {
method bar i [makebody {my bar $i}]
}
oo::class create boo {
superclass foo
method bar i [makebody {next $i}]
}
} -body {
setabs
[boo new] bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
test nre-oo.5 {really deep calls in oo - forwards} -setup {
oo::object create foo
set body [makebody {my boo $i}]
oo::objdefine foo "
method bar i {$body}
forward boo ::foo bar
"
} -body {
setabs
foo bar 0
} -cleanup {
foo destroy
} -constraints {
testnrelevels
} -result {{0 2 1 1} 0}
#
# NASTY BUG found by tcllib's interp package
#
test nre-X.1 {eval in wrong interp} -setup {
set i [interp create]
|
| ︙ | ︙ |
Changes to tests/obj.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
|
| ︙ | ︙ |
Changes to tests/oo.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2012 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to tests/ooNext2.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | < < | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
|
| ︙ | ︙ |
Changes to tests/parse.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
| > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
cleanupTests
}
namespace delete ::tcl::test::parse
return
| > > > > > > > > | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X}
test parse-20.11 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 4
} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X}
test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
test parse-21.0 {Bug 1884496} testevent {
set ::script {set a [p]; return -level 0 $a}
proc ::p {} {string first s $::script}
testevent queue a head $::script
update
} {}
cleanupTests
}
namespace delete ::tcl::test::parse
return
|
Changes to tests/parseExpr.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
|
| ︙ | ︙ |
Changes to tests/parseOld.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
| > > > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# 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]]
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
|
| ︙ | ︙ |
Changes to tests/platform.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
|
| ︙ | ︙ |
Changes to tests/reg.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
|
| ︙ | ︙ |
Changes to tests/registry.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
| | < < < | | > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::regver [package require registry 1.3.0]
}]} {
testConstraint reg 1
}
}
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
} {1.3.0}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
| | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
} "foo ba\u00c7r baz"
test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u0000r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} [string repeat x 16383]
test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup {
|
| ︙ | ︙ |
Changes to tests/rename.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
|
| ︙ | ︙ |
Changes to tests/resolver.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
namespace export z
|
| ︙ | ︙ |
Changes to tests/result.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
|
| ︙ | ︙ |
Changes to tests/set.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | # 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::* # Some tests require the Thread package or exec command | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
# 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::*
# 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]]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
proc randport {} { expr {int(rand()*16383+49152)} }
# Test the latency of tcp connections over the loopback interface. Some OSes
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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 testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 |
test string-18.10 {string trim} {
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} {
| | | | | | | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 |
test string-18.10 {string trim} {
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
} ABC\u1361
test string-19.1 {string trimleft} {
list [catch {string trimleft} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
test string-19.2 {string trimleft} {
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
} \u1361ABC
test string-20.1 {string trimright errors} {
list [catch {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, 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 "
} { XYZ}
test string-20.4 {string trimright} {
string trimright " "
} {}
test string-20.5 {string trimright} {
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
} ABC\u1361
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"}}
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 |
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 {
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 {
tcl::prefix match -error str1 str2
| | | | 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 |
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 {
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 {
tcl::prefix match -error str1 str2
} -returnCodes 1 -result {missing value for -error}
test string-26.4 {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
} -returnCodes 1 -result {missing value for -message}
test string-26.5 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
test string-26.6 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
|
| ︙ | ︙ |
Changes to tests/stringComp.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
| > > > | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# 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] != {}}]
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, 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
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
[string match *a*l*\u0000*cba* $longString] \
[string match *===* $longString]
}
foo
} {0 1 1 1 0 0}
## string range
| > > > > | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
[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
## not yet bc
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 | ## not yet bc ## string trim* ## not yet bc ## string word* ## not yet bc | | > > > > | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
## not yet bc
## string trim*
## not yet bc
## string word*
## not yet bc
# cleanup
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/stringObj.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
| > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# 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]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
|
| ︙ | ︙ |
Changes to tests/tailcall.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ |
Changes to tests/thread.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
# Some tests require the Thread package
| > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
# Some tests require the Thread package
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# Some tests may not work under valgrind
testConstraint notValgrind [expr {![testConstraint valgrind]}]
set threadSuperKillScript {
rename catch ""
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
while {[set x [testthread event]]} {
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
if {[testConstraint thread]} {
thread::errorproc ThreadError
}
if {[testConstraint testthread]} {
proc drainEventQueue {} {
while {[set x [testthread event]]} {
#puts "WARNING: drained $x event(s) on main thread"
}
}
testthread errorproc ThreadError
set mainThread [testthread id]
|
| ︙ | ︙ |
Changes to tests/trace.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc getbytes {} {
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# 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]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
proc getbytes {} {
|
| ︙ | ︙ |
Changes to tests/unixFCmd.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
|
| ︙ | ︙ |
Changes to tests/unixFile.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
| > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# 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]]
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
|
| ︙ | ︙ |
Changes to tests/unixNotfy.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
| | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# 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
|
| ︙ | ︙ |
Changes to tests/unload.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
|
| ︙ | ︙ |
Changes to tests/utf.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
| > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
|
| ︙ | ︙ |
Changes to tests/util.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
# Big test for correct ordering of data in [expr]
| > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# 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]]
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to tests/var.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
| > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
|
| ︙ | ︙ |
Changes to tests/winDde.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
| > > > | < < < | > | < | < < > < | < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
#tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::ddever [package require dde 1.4.0]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
}
# -------------------------------------------------------------------------
# Setup a script for a test server
#
set scriptName [makeFile {} script1.tcl]
proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
| > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
} {1.4.0}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1 ""
dde execute -async TclEval self [list set \xe1 foo]
update
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
| | | | | | | | | | | | | > > > > > > > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1 ""
dde execute -async TclEval self [list set \xe1 foo]
update
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request TclEval self \xe1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
set \xe1 ""
dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf8} -constraints dde -body {
set \xe1 "not set"
dde execute TclEval self "set \xe1 \xc4"
scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints dde -body {
set \xe1 "not set"
dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
scan [set \xe1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke TclEval self \xe1 \xc4
dde request TclEval self \xe1
} -result \xc4
test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke -binary TclEval self \xe1 \xc3\x84\x00
dde request TclEval self \xe1
} -result \xc4
# -------------------------------------------------------------------------
test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.1
set child [createChildProcess $name]
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
| | | | | | | | > > > > > > > > > > | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
dde execute TclEval $name [list set \xe1 foo]
set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
set \xe1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
set \xe1 [dde eval $name set \xe1 foo]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
set \xe1 ""
set name ch\xEDld-4.5
set child [createChildProcess $name]
dde poke TclEval $name \xe1 foo
set \xe1 [dde request TclEval $name \xe1]
dde execute TclEval $name {set done 1}
update
set \xe1
} -result foo
# -------------------------------------------------------------------------
test winDde-5.1 {check for bad arguments} -constraints dde -body {
dde execute "" "" "" ""
} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
test winDde-5.2 {check for bad arguments} -constraints dde -body {
|
| ︙ | ︙ |
Changes to tests/winFCmd.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
# Initialise the test constraints
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
|
| ︙ | ︙ |
Changes to tests/winFile.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace import -force ::tcltest::*
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
testConstraint win2000 0
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
| > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
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"}]
}
|
| ︙ | ︙ |
Changes to tests/winNotify.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
after 1000 { set done 1 }
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
after 1000 { set done 1 }
|
| ︙ | ︙ |
Changes to tests/winPipe.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
| > > > > > > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
testConstraint testexcept [llength [info commands testexcept]]
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
| | > | > | > | > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}
set path(nothing) [makeFile {} nothing]
close [open $path(nothing) w]
|
| ︙ | ︙ |
Changes to tests/winTime.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
| > > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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]]
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
|
| ︙ | ︙ |
Changes to tests/zlib.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # 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. | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
# 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 zlib [llength [info commands zlib]]
test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
zlib
} -result {wrong # args: should be "zlib command arg ?...?"}
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
test zlib-1.3 {zlib basics} -constraints zlib -body {
zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
package present zlib
} -result 2.0
test zlib-2.1 {zlib compress/decompress} zlib {
zlib decompress [zlib compress abcdefghijklm]
} abcdefghijklm
test zlib-3.1 {zlib deflate/inflate} zlib {
zlib inflate [zlib deflate abcdefghijklm]
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
set s [zlib stream compress]
} -body {
$s ?
} -cleanup {
$s close
| | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup {
set s [zlib stream compress]
} -body {
$s ?
} -cleanup {
$s close
} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset}
test zlib-7.1 {zlib stream} zlib {
set s [zlib stream compress]
$s put -finalize abcdeEDCBA
set data [$s get]
set result [list [$s get] [format %x [$s checksum]]]
$s close
lappend result [zlib decompress $data]
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
after 250 {lappend ::res MIDDLE}
vwait ::done
set ::res
} -cleanup {
catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
set file [makeFile {} test.gz]
set f [open $sfile wb]
puts -nonewline $f [zlib gzip [string repeat a 81920]]
close $f
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
after 250 {lappend ::res MIDDLE}
vwait ::done
set ::res
} -cleanup {
catch {close $r}
} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-8.6 {transformation and fconfigure} -setup {
set file [makeFile {} test.z]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
test zlib-8.7 {transformation and fconfigure} -setup {
set file [makeFile {} test.gz]
set fd [open $file wb]
} -constraints zlib -body {
list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
# Input is headers from fetching SPDY draft
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
test zlib-8.8 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib decompress $compressed} err opt
list [string length [zlib compress $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode] [zlib adler32 $spdyDict]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
test zlib-8.9 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
set result [fconfigure $outSide -checksum]
chan pop $outSide
$strm put -dictionary $spdyDict [read $inSide]
lappend result [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {3064818174 358 358}
test zlib-8.10 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
catch {zlib inflate $compressed} err opt
list [string length [zlib deflate $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
} -result {254 212 {data error} {TCL ZLIB DATA}}
test zlib-8.11 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream inflate]
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
$strm put -dictionary $spdyDict [read $inSide]
list [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.12 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide
fconfigure $outSide -blocking 0 -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]] \
[fconfigure $inSide -checksum]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.13 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]] \
[fconfigure $inSide -checksum]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
test zlib-8.14 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide
fconfigure $outSide -blocking 0 -buffering none -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.15 {transformtion and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -buffering none -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
list [string length $spdyHeaders] [string length [read $inSide]]
} -cleanup {
catch {close $outSide}
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
set file [makeFile {} test.gz]
set f [open $sfile wb]
puts -nonewline $f [zlib gzip [string repeat a 81920]]
close $f
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
close $f
set d [zlib gunzip $d -header h]
list [regexp -all "hello" $d] [dict get $h filename] \
[string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 /foo/bar 0}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
close $f
set d [zlib gunzip $d -header h]
list [regexp -all "hello" $d] [dict get $h filename] \
[string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 /foo/bar 0}
test zlib-11.3 {Bug 3595576 variant} -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \
[string repeat "hello" 1000]
close $f
set f [open $file rb]
set d [read $f]
close $f
zlib gunzip $d -header noSuchNs::foo
} -cleanup {
removeFile $file
} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tools/README.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
Generating Windows Help Files:
1) Build tcl in the ../unix directory
2) On UNIX, (after autoconf and configure), do
make
this converts the Nroff to RTF files.
2) On Windows, convert the RTF to a Help doc, do
nmake helpfile
| < < < | 19 20 21 22 23 24 25 |
Generating Windows Help Files:
1) Build tcl in the ../unix directory
2) On UNIX, (after autoconf and configure), do
make
this converts the Nroff to RTF files.
2) On Windows, convert the RTF to a Help doc, do
nmake helpfile
|
Changes to tools/genStubs.tcl.
| ︙ | ︙ | |||
824 825 826 827 828 829 830 |
} else {
eval {append temp} $skipString
}
}
append text [addPlatformGuard $plat $temp {} true]
}
## macosx ##
| | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
} else {
eval {append temp} $skipString
}
}
append text [addPlatformGuard $plat $temp {} true]
}
## macosx ##
if {($block(unix) || $block(macosx)) && !$block(aqua) && !$block(x11)} {
set temp {}
set lastNum -1
foreach plat {unix macosx} {
if {$block($plat)} {
set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
? $lastNum : $stubs($name,$plat,lastNum)}]
}
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 |
append text "#define ${CAPName}_STUBS_EPOCH $epoch\n"
append text "#define ${CAPName}_STUBS_REVISION $revision\n"
}
emitDeclarations $name text
if {[info exists hooks($name)]} {
| | > | > > > | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
append text "#define ${CAPName}_STUBS_EPOCH $epoch\n"
append text "#define ${CAPName}_STUBS_REVISION $revision\n"
}
emitDeclarations $name text
if {[info exists hooks($name)]} {
append text "\ntypedef struct {\n"
foreach hook $hooks($name) {
set capHook [string toupper [string index $hook 0]]
append capHook [string range $hook 1 end]
append text " const struct ${capHook}Stubs *${hook}Stubs;\n"
}
append text "} ${capName}StubHooks;\n"
}
append text "\ntypedef struct ${capName}Stubs {\n"
append text " int magic;\n"
if {$epoch ne ""} {
append text " int epoch;\n"
append text " int revision;\n"
}
if {[info exists hooks($name)]} {
append text " const ${capName}StubHooks *hooks;\n\n"
} else {
append text " void *hooks;\n\n"
}
emitSlots $name text
append text "} ${capName}Stubs;\n\n"
append text "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
append text "extern const ${capName}Stubs *${name}StubsPtr;\n"
|
| ︙ | ︙ |
Changes to tools/str2c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
* Single part writeable string generated by str2c
*/
static char data\[\]=\"[translate $r]\";"
} else {
puts "/*
* Multi parts read only string generated by str2c
*/
| | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
* Single part writeable string generated by str2c
*/
static char data\[\]=\"[translate $r]\";"
} else {
puts "/*
* Multi parts read only string generated by str2c
*/
static const char * const data\[\]= {"
set n 1
for {set i 0} {$i<$lg} {incr i $MAX} {
set part [string range $r $i [expr $i+$MAX-1]]
set len [string length $part];
puts "\t/* Start of part $n ($len characters) */"
puts "\t\"[translate $part]\","
puts "\t/* End of part $n */\n"
incr n
}
puts "\tNULL\t/* End of data marker */\n};"
puts "\n/* use for instance with:
const char * const *chunk;
for (chunk=data; *chunk; chunk++) {
Tcl_AppendResult(interp, *chunk, (char *) NULL);
}
*/"
}
|
| ︙ | ︙ |
Deleted tools/tcl.wse.in.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/tclSplash.bmp.
cannot compute difference between binary files
Deleted tools/tclmin.wse.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to tools/tcltk-man2html-utils.tcl.
| ︙ | ︙ | |||
632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
set name [string trim $name]
if {[llength $name] > 1} {
manerror "name has a space: {$name}\nfrom: $line"
}
lappend manual(wing-toc) $name
lappend manual(name-$name) $manual(wing-file)/$manual(name)
}
}
##
## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
global manual remap_link_target
| > | 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
set name [string trim $name]
if {[llength $name] > 1} {
manerror "name has a space: {$name}\nfrom: $line"
}
lappend manual(wing-toc) $name
lappend manual(name-$name) $manual(wing-file)/$manual(name)
}
set manual(tooltip-$manual(wing-file)/$manual(name).htm) $line
}
##
## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
global manual remap_link_target
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
switch -exact -- [string index $code end]:$manual(section) {
H:NAME {
set names {}
while {1} {
set line [next-text]
if {[is-a-directive $line]} {
backup-text 1
| > | > | 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
switch -exact -- [string index $code end]:$manual(section) {
H:NAME {
set names {}
while {1} {
set line [next-text]
if {[is-a-directive $line]} {
backup-text 1
if {[llength $names]} {
output-name [join $names { }]
}
return
}
lappend names [string trim $line]
}
}
H:SYNOPSIS {
lappend manual(section-toc) <DL>
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
manual(wing-description)
set manual(wing-copyrights) {}
makedirhier $outputDir/$manual(wing-file)
set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w]
# whistle
puts stderr "scanning section $manual(wing-name)"
# put the entry for this section into the short table of contents
| > > > | > | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
manual(wing-description)
set manual(wing-copyrights) {}
makedirhier $outputDir/$manual(wing-file)
set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w]
# whistle
puts stderr "scanning section $manual(wing-name)"
# put the entry for this section into the short table of contents
if {[regexp {^(.+), version (.+)$} $manual(wing-name) -> name version]} {
puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\" TITLE=\"version $version\">$name</A></DT><DD>$manual(wing-description)</DD>"
} else {
puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>"
}
# initialize the wing table of contents
puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \
$manual(wing-name) $overall_title "../[indexfile]"]
# initialize the short table of contents for this section
set manual(wing-toc) {}
# initialize the man directory for this section
makedirhier $outputDir/$manual(wing-file)
|
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 |
}
if {![parse-directive $line code rest]} {
addbuffer $line
continue
}
switch -exact -- $code {
.if - .nr - .ti - .in - .ie - .el -
| | | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
}
if {![parse-directive $line code rest]} {
addbuffer $line
continue
}
switch -exact -- $code {
.if - .nr - .ti - .in - .ie - .el -
.ad - .na - .so - .ne - .AS - .HS - .VE - .VS - . {
# ignore
continue
}
}
switch -exact -- $code {
.SH - .SS {
flushbuffer
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 |
foreach name [lsort -dictionary $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
| > > > > | > > > | > | 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
foreach name [lsort -dictionary $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
if {[info exists manual(tooltip-$manual(wing-file)/$tail.htm)]} {
set tooltip $manual(tooltip-$manual(wing-file)/$tail.htm)
set tooltip [string map {[ {\[} ] {\]} $ {\$} \\ \\\\} $tooltip]
regsub {^[^-]+-\s*(.)} $tooltip {[string totitle \1]} tooltip
append rows([expr {$n%$nrows}]) \
"<td> <a href=\"$tail.htm\" title=\"[subst $tooltip]\">$name</a> </td>"
} else {
append rows([expr {$n%$nrows}]) \
"<td> <a href=\"$tail.htm\">$name</a> </td>"
}
incr n
}
puts $manual(wing-toc-fp) <table>
foreach row [lsort -integer [array names rows]] {
puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
}
puts $manual(wing-toc-fp) </table>
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
1 2 | #!/usr/bin/env tclsh | | > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#!/usr/bin/env tclsh
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)."
exit 1
}
# Convert Ousterhout format man pages into highly crosslinked hypertext.
#
# Along the way detect many unmatched font changes and other odd things.
#
# Note well, this program is a hack rather than a piece of software
# engineering. In that sense it's probably a good example of things
# that a scripting language, like Tcl, can do well. It is offered as
# an example of how someone might convert a specific set of man pages
# into hypertext, not as a general solution to the problem. If you
# try to use this, you'll be very much on your own.
#
# Copyright (c) 1995-1997 Roger E. Critchlow Jr
# Copyright (c) 2004-2010 Donal K. Fellows
set ::Version "50/8.6"
set ::CSSFILE "docs.css"
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
|
| ︙ | ︙ | |||
324 325 326 327 328 329 330 |
set k [string range $k 8 end]
puts $afp "<DT><A NAME=\"$k\">$k</A></DT>"
puts $afp "<DD>"
set refs {}
foreach man $manual(keyword-$k) {
set name [lindex $man 0]
set file [lindex $man 1]
| > > > > > > > | > | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
set k [string range $k 8 end]
puts $afp "<DT><A NAME=\"$k\">$k</A></DT>"
puts $afp "<DD>"
set refs {}
foreach man $manual(keyword-$k) {
set name [lindex $man 0]
set file [lindex $man 1]
if {[info exists manual(tooltip-$file)]} {
set tooltip $manual(tooltip-$file)
if {[string match {*[<>""]*} $tooltip]} {
manerror "bad tooltip for $file: \"$tooltip\""
}
lappend refs "<A HREF=\"../$file\" TITLE=\"$tooltip\">$name</A>"
} else {
lappend refs "<A HREF=\"../$file\">$name</A>"
}
}
puts $afp "[join $refs {, }]</DD>"
}
puts $afp "</DL>"
# insert merged copyrights
puts $afp [copyout $manual(merge-copyrights)]
puts $afp "</BODY></HTML>"
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
}
return {}
}
##
## Helper for assembling the descriptions of base packages (i.e., Tcl and Tk).
##
| | > > > > > > > > > > | | | | | < < | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 |
}
return {}
}
##
## Helper for assembling the descriptions of base packages (i.e., Tcl and Tk).
##
proc plus-base {var root glob name dir desc} {
global tcltkdir
if {$var} {
if {[file exists $tcltkdir/$root/README]} {
set f [open $tcltkdir/$root/README]
set d [read $f]
close $f
if {[regexp {This is the \w+ (\S+) source distribution} $d -> version]} {
append name ", version $version"
}
}
set glob $root/$glob
return [list $tcltkdir/$glob $name $dir $desc]
}
}
##
## Helper for assembling the descriptions of contributed packages.
##
proc plus-pkgs {type args} {
global build_tcl tcltkdir tcldir
if {$type ni {n 3}} {
error "unknown type \"$type\": must be 3 or n"
}
if {!$build_tcl} return
set result {}
set pkgsdir $tcltkdir/$tcldir/pkgs
foreach {dir name version} $args {
set globpat $pkgsdir/$dir/doc/*.$type
if {![llength [glob -type f -nocomplain $globpat]]} {
# Fallback for manpages generated using doctools
set globpat $pkgsdir/$dir/doc/man/*.$type
if {![llength [glob -type f -nocomplain $globpat]]} {
continue
}
}
switch $type {
n {
set title "$name Package Commands"
if {$version ne ""} {
append title ", version $version"
}
set dir [string totitle $dir]Cmd
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
}
if {$build_tk} {
append tcltkdesc "Tk"
append cmdesc "Tk"
append appdir "$tkdir"
}
# Get the list of packages to try, and what their human-readable names
# are. Note that the package directory list should be version-less.
try {
set packageDirNameMap {}
if {$build_tcl} {
set f [open $tcltkdir/$tcldir/pkgs/package.list.txt]
try {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
}
if {$build_tk} {
append tcltkdesc "Tk"
append cmdesc "Tk"
append appdir "$tkdir"
}
# When building docs for Tcl, try to build docs for bundled packages too
set packageBuildList {}
if {$build_tcl} {
set pkgsDir [file join $tcltkdir $tcldir pkgs]
set subdirs [glob -nocomplain -types d -tails -directory $pkgsDir *]
foreach dir [lsort $subdirs] {
# Parse the subdir name into (name, version) as fallback...
set description [split $dir -]
if {2 != [llength $description]} {
regexp {([^0-9]*)(.*)} $dir -> n v
set description [list $n $v]
}
# ... but try to extract (name, version) from subdir contents
try {
set f [open [file join $pkgsDir $dir configure.in]]
foreach line [split [read $f] \n] {
if {2 == [scan $line \
{ AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} {
set description [list $n $v]
break
}
}
} finally {
catch {close $f; unset f}
}
if {[file exists [file join $pkgsDir $dir configure]]} {
# Looks like a package, record our best extraction attempt
lappend packageBuildList $dir {*}$description
}
}
}
# Get the list of packages to try, and what their human-readable names
# are. Note that the package directory list should be version-less.
try {
set packageDirNameMap {}
if {$build_tcl} {
set f [open $tcltkdir/$tcldir/pkgs/package.list.txt]
try {
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 652 653 654 655 656 657 |
set packageDirNameMap {
itcl {[incr Tcl]}
tdbc {TDBC}
thread Thread
}
}
#
# Invoke the scraper/converter engine.
#
make-man-pages $webdir \
[list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \
"The interpreters which implement $cmdesc."] \
| > > > > > > > > | | | | | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 |
set packageDirNameMap {
itcl {[incr Tcl]}
tdbc {TDBC}
thread Thread
}
}
# Convert to human readable names, if applicable
for {set idx 0} {$idx < [llength $packageBuildList]} {incr idx 3} {
lassign [lrange $packageBuildList $idx $idx+2] d n v
if {[dict exists $packageDirNameMap $n]} {
lset packageBuildList $idx+1 [dict get $packageDirNameMap $n]
}
}
#
# Invoke the scraper/converter engine.
#
make-man-pages $webdir \
[list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \
"The interpreters which implement $cmdesc."] \
[plus-base $build_tcl $tcldir doc/*.n {Tcl Commands} TclCmd \
"The commands which the <B>tclsh</B> interpreter implements."] \
[plus-base $build_tk $tkdir doc/*.n {Tk Commands} TkCmd \
"The additional commands which the <B>wish</B> interpreter implements."] \
{*}[plus-pkgs n {*}$packageBuildList] \
[plus-base $build_tcl $tcldir doc/*.3 {Tcl C API} TclLib \
"The C functions which a Tcl extended C program may use."] \
[plus-base $build_tk $tkdir doc/*.3 {Tk C API} TkLib \
"The additional C functions which a Tk extended C program may use."] \
{*}[plus-pkgs 3 {*}$packageBuildList]
} on error {msg opts} {
# On failure make sure we show what went wrong. We're not supposed
# to get here though; it represents a bug in the script.
puts $msg\n[dict get $opts -errorinfo]
exit 1
}
# Local-Variables:
# mode: tcl
# End:
|
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | MAC_OSX_DIR = $(TOP_DIR)/macosx PKGS_DIR = $(TOP_DIR)/pkgs # Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest # Must be absolute to so the corresponding tcltest's tcl_library is absolute. TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library | | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 |
MAC_OSX_DIR = $(TOP_DIR)/macosx
PKGS_DIR = $(TOP_DIR)/pkgs
# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library
ZLIB_DIR = ${COMPAT_DIR}/zlib
ZLIB_INCLUDE = @ZLIB_INCLUDE@
CC = @CC@
#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).
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 617 618 619 620 621 622 623 |
doc:
# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
rm -f $@
@MAKE_LIB@
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
rm -f $@
@MAKE_STUB_LIB@
# Make target which outputs the list of the .o contained in the Tcl lib useful
# to build a single big shared library containing Tcl and other extensions.
| > > > > | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
doc:
# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
rm -f $@
@MAKE_LIB@
@if test "x$(DLL_INSTALL_DIR)" = "x$(BIN_INSTALL_DIR)"; then\
cp ${ZLIB_DIR}/win32/zlib1.dll .;\
fi
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
rm -f $@
@MAKE_STUB_LIB@
# Make target which outputs the list of the .o contained in the Tcl lib useful
# to build a single big shared library containing Tcl and other extensions.
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 786 787 | do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ | > > > > > | | | | | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
else true; \
fi; \
done;
@if test "x$(DLL_INSTALL_DIR)" = "x$(BIN_INSTALL_DIR)"; then\
echo "Installing zlib1.dll to $(BIN_INSTALL_DIR)/";\
$(INSTALL_LIBRARY) zlib1.dll "$(BIN_INSTALL_DIR)";\
chmod 555 "$(BIN_INSTALL_DIR)/zlib1.dll";\
fi
@echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/"
@@INSTALL_LIB@
@chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)"
@echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
@$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
@echo "Installing tclConfig.sh to $(CONFIG_INSTALL_DIR)/"
@$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)/tclConfig.sh"
@echo "Installing tclooConfig.sh to $(CONFIG_INSTALL_DIR)/"
@$(INSTALL_DATA) $(UNIX_DIR)/tclooConfig.sh \
"$(CONFIG_INSTALL_DIR)/tclooConfig.sh"
@if test "$(STUB_LIB_FILE)" != "" ; then \
echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
@INSTALL_STUB_LIB@ ; \
fi
@EXTRA_INSTALL_BINARIES@
@echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/"
@$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 | $(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; | | | | | | | | | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 |
$(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.8.6 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.6.tm;
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
@for i in $(TOP_DIR)/library/opt/*.tcl ; \
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
done;
@echo "Installing package msgcat 1.5.0 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm;
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm;
@echo "Installing package platform 1.0.10 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.10.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/";
@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 \
echo "Customizing tcl module path"; \
echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \
"$(SCRIPT_INSTALL_DIR)"/tm.tcl; \
fi
install-tzdata: ${NATIVE_TCLSH}
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
@${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \
$(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata
install-msgs:
@for i in msgs; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 | do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; | | | | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 | 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)/"; @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)/"; @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 install-headers: @for i in "$(INCLUDE_INSTALL_DIR)"; \ do \ |
| ︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 |
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'"; \
| | | < < | | | | | 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
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 $$?; \
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 $$?; \
fi; \
fi; \
done
test-packages: tcltest 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}"; ) \
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; ) \
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; ) \
fi; \
rm -rf $(PKG_DIR)/$$pkg; \
fi; \
done; \
rm -rf $(PKG_DIR)
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 $$?; \
fi; \
fi; \
done
#--------------------------------------------------------------------------
# Maintainer-only targets
|
| ︙ | ︙ | |||
1917 1918 1919 1920 1921 1922 1923 | $(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/ldAix | < | 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 | $(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/ldAix mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ |
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 | cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README \ $(DISTDIR)/unix/dltest mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ | < | | < | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 | cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README \ $(DISTDIR)/unix/dltest mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in mkdir $(DISTDIR)/libtommath cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ $(DISTDIR)/libtommath mkdir $(DISTDIR)/pkgs cp $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ |
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | # include <stdint.h> # endif #endif #if HAVE_UNISTD_H # include <unistd.h> #endif" | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | # include <stdint.h> # endif #endif #if 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_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false # The variables have the same names as the options, with # dashes changed to underlines. |
| ︙ | ︙ | |||
1331 1332 1333 1334 1335 1336 1337 | TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 | | | > > > | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 |
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".0"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
#------------------------------------------------------------------------
PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"
if test -r "$cache_file" -a -f "$cache_file"; then
case $cache_file in
[\\/]* | ?:[\\/]* ) pkg_cache_file=$cache_file ;;
*) pkg_cache_file=../../$cache_file ;;
esac
PKG_CFG_ARGS="${PKG_CFG_ARGS} --cache-file=$pkg_cache_file"
fi
#------------------------------------------------------------------------
# Empty slate for bundled packages, to avoid stale configuration
#------------------------------------------------------------------------
#rm -Rf pkgs
if test -f Makefile; then
make distclean-packages
fi
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
if test "${prefix}" = "NONE"; then
prefix=/usr/local
|
| ︙ | ︙ | |||
6333 6334 6335 6336 6337 6338 6339 | fi fi if test $zlib_ok = no; then | < < | 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 |
fi
fi
if test $zlib_ok = no; then
ZLIB_OBJS=\${ZLIB_OBJS}
ZLIB_SRCS=\${ZLIB_SRCS}
ZLIB_INCLUDE=-I\${ZLIB_DIR}
|
| ︙ | ︙ | |||
7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 |
fi
echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
echo "${ECHO_T}$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
;;
dgux*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD='${CC} -G'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
| > > > > > > > > > > | 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 |
fi
echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
echo "${ECHO_T}$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; }; }
fi
if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde14.dll" -a ! -f "../win/tk86.dll"; then
{ { echo "$as_me:$LINENO: error: Please configure and make the ../win directory first." >&5
echo "$as_me: error: Please configure and make the ../win directory first." >&2;}
{ (exit 1); exit 1; }; }
fi
;;
dgux*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD='${CC} -G'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
|
| ︙ | ︙ | |||
8745 8746 8747 8748 8749 8750 8751 | 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 | | | 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 |
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
echo "$as_me:$LINENO: result: yes" >&5
echo "${ECHO_T}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
|
| ︙ | ︙ | |||
8944 8945 8946 8947 8948 8949 8950 | if test "$use_sunmath" = yes; then textmode=textoff else textmode=text fi case $system in | | | 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 |
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}";;
*)
SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";;
esac
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
|
| ︙ | ︙ | |||
9138 9139 9140 9141 9142 9143 9144 |
fi
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
| | | | | | | | 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 |
fi
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${TCL_SHLIB_LD_EXTRAS} ${SHLIB_LD_LIBS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
if test "${SHLIB_SUFFIX}" = ".dll"; then
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
else
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
fi
else
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
if test "$RANLIB" = ""; then
MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
else
MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)" ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(LIB_FILE))'
fi
fi
# Stub lib does not depend on shared/static configuration
if test "$RANLIB" = ""; then
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"'
else
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)" ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(STUB_LIB_FILE))'
fi
# 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.
|
| ︙ | ︙ | |||
14387 14388 14389 14390 14391 14392 14393 | #-------------------------------------------------------------------- # Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But # we might be able to use fstatfs instead. Some systems (OpenBSD?) also # lack blkcnt_t. #-------------------------------------------------------------------- | | > > > > | | 14398 14399 14400 14401 14402 14403 14404 14405 14406 14407 14408 14409 14410 14411 14412 14413 14414 14415 14416 14417 |
#--------------------------------------------------------------------
# Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But
# we might be able to use fstatfs instead. Some systems (OpenBSD?) also
# lack blkcnt_t.
#--------------------------------------------------------------------
if test "$ac_cv_cygwin" = "yes"; then
if test "x${SHARED_BUILD}" = "x1"; then
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS} \${COMPAT_DIR}/zlib/win32/zdll.lib"
fi
else
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
|
| ︙ | ︙ | |||
19421 19422 19423 19424 19425 19426 19427 |
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html'
| | | | 19436 19437 19438 19439 19440 19441 19442 19443 19444 19445 19446 19447 19448 19449 19450 19451 |
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
|
| ︙ | ︙ | |||
20209 20210 20211 20212 20213 20214 20215 | 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 | < | 20224 20225 20226 20227 20228 20229 20230 20231 20232 20233 20234 20235 20236 20237 | 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 |
| ︙ | ︙ |
Changes to unix/configure.in.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 |
/* override */ #undef PACKAGE_TARNAME
#endif /* _TCLCONFIG */])
])
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
| | | > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
/* override */ #undef PACKAGE_TARNAME
#endif /* _TCLCONFIG */])
])
TCL_VERSION=8.6
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=6
TCL_PATCH_LEVEL=".0"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
#------------------------------------------------------------------------
PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"
if test -r "$cache_file" -a -f "$cache_file"; then
case $cache_file in
[[\\/]]* | ?:[[\\/]]* ) pkg_cache_file=$cache_file ;;
*) pkg_cache_file=../../$cache_file ;;
esac
PKG_CFG_ARGS="${PKG_CFG_ARGS} --cache-file=$pkg_cache_file"
fi
#------------------------------------------------------------------------
# Empty slate for bundled packages, to avoid stale configuration
#------------------------------------------------------------------------
#rm -Rf pkgs
if test -f Makefile; then
make distclean-packages
fi
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
if test "${prefix}" = "NONE"; then
prefix=/usr/local
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 |
AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include <zlib.h>])],[
zlib_ok=no])
AS_IF([test $zlib_ok = yes], [
AC_SEARCH_LIBS([deflateSetHeader],[z],[],[
zlib_ok=no
])])
AS_IF([test $zlib_ok = no], [
| < | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include <zlib.h>])],[
zlib_ok=no])
AS_IF([test $zlib_ok = yes], [
AC_SEARCH_LIBS([deflateSetHeader],[z],[],[
zlib_ok=no
])])
AS_IF([test $zlib_ok = no], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}])
AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])])
SC_TCL_IPV6
| | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])])
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
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 | #-------------------------------------------------------------------- # Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But # we might be able to use fstatfs instead. Some systems (OpenBSD?) also # lack blkcnt_t. #-------------------------------------------------------------------- | | > > > > | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
#--------------------------------------------------------------------
# Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But
# we might be able to use fstatfs instead. Some systems (OpenBSD?) also
# lack blkcnt_t.
#--------------------------------------------------------------------
if test "$ac_cv_cygwin" = "yes"; then
if test "x${SHARED_BUILD}" = "x1"; then
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS} \${COMPAT_DIR}/zlib/win32/zdll.lib"
fi
else
AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize])
fi
AC_CHECK_TYPES([blkcnt_t])
AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])])
#--------------------------------------------------------------------
# Some system have no memcmp or it does not work with 8 bit data, this
# checks it and add memcmp.o to LIBOBJS if needed
|
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
AC_CHECK_TYPE([intptr_t], [
AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
for tcl_cv_intptr_t in "int" "long" "long long" none; do
if test "$tcl_cv_intptr_t" != none; then
AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
| | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
AC_CHECK_TYPE([intptr_t], [
AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
for tcl_cv_intptr_t in "int" "long" "long long" none; do
if test "$tcl_cv_intptr_t" != none; then
AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
[[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])],
[tcl_ok=yes], [tcl_ok=no])
test "$tcl_ok" = yes && break; fi
done])
if test "$tcl_cv_intptr_t" != none; then
AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer
type wide enough to hold a pointer.])
fi
])
AC_CHECK_TYPE([uintptr_t], [
AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [
AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [
for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \
none; do
if test "$tcl_cv_uintptr_t" != none; then
AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
[[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])],
[tcl_ok=yes], [tcl_ok=no])
test "$tcl_ok" = yes && break; fi
done])
if test "$tcl_cv_uintptr_t" != none; then
AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer
type wide enough to hold a pointer.])
fi
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
AC_HELP_STRING([--with-tzdata],
[install timezone data (default: autodetect)]),
[tcl_ok=$withval], [tcl_ok=auto])
#
# Any directories that get added here must also be added to the
# search path in ::tcl::clock::Initialize (library/clock.tcl).
#
| | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 |
AC_HELP_STRING([--with-tzdata],
[install timezone data (default: autodetect)]),
[tcl_ok=$withval], [tcl_ok=auto])
#
# 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)
AC_MSG_RESULT([supplied by OS vendor])
;;
yes)
# nothing to do here
;;
auto*)
|
| ︙ | ︙ | |||
701 702 703 704 705 706 707 |
tcl_ok=no
AC_MSG_RESULT([$dir])
else
tcl_ok=yes
fi
;;
*)
| | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
tcl_ok=no
AC_MSG_RESULT([$dir])
else
tcl_ok=yes
fi
;;
*)
AC_MSG_ERROR([invalid argument: $tcl_ok])
;;
esac
if test $tcl_ok = yes
then
AC_MSG_RESULT([supplied by Tcl])
INSTALL_TZDATA=install-tzdata
fi
|
| ︙ | ︙ | |||
775 776 777 778 779 780 781 |
#--------------------------------------------------------------------
TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
| | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
#--------------------------------------------------------------------
TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)'
PRIVATE_INCLUDE_DIR='$(includedir)'
HTML_DIR='$(DISTDIR)/html'
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html'
| | | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 |
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TclTOC.html'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
|
| ︙ | ︙ |
Changes to unix/dltest/pkgb.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" | < < < < < < < < > > > > > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* Prototypes for procedures defined later in this file:
*/
static int Pkgb_SubObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkgb_UnsafeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkgb_DemoObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
*
* Pkgb_SubObjCmd --
*
* This procedure is invoked to process the "pkgb_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
#ifndef Tcl_GetErrorLine
# define Tcl_GetErrorLine(interp) ((interp)->errorLine)
#endif
static int
Pkgb_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d", Tcl_GetErrorLine(interp));
Tcl_AppendResult(interp, " in line: ", buf, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
static int
Pkgb_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| > > > > > > > > > > > > > > > > > > | > | | | | | | | | | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
static int
Pkgb_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);
}
static int
Pkgb_DemoObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4)
Tcl_Obj *first;
if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first)
== TCL_OK) {
Tcl_SetObjResult(interp, first);
}
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1));
#endif
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
DLLEXPORT int
Pkgb_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL);
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgb_demo", Pkgb_DemoObjCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_SafeInit --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to a safe interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
DLLEXPORT int
Pkgb_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL);
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, NULL, NULL);
return TCL_OK;
}
|
Changes to unix/install-sh.
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
shift;;
-o) chowncmd="$chownprog $2"
shift;;
-s) stripcmd=$stripprog;;
| | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
shift;;
-o) chowncmd="$chownprog $2"
shift;;
-s) stripcmd=$stripprog;;
-S) stripcmd="$stripprog $2"
shift;;
-t) dst_arg=$2
shift;;
-T) no_target_directory=true;;
--version) echo "$0 $scriptversion"; exit $?;;
|
| ︙ | ︙ |
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 |
], [],
ac_cv_cygwin=no,
ac_cv_cygwin=yes)
)
if test "$ac_cv_cygwin" = "no"; then
AC_MSG_ERROR([${CC} is not a cygwin compiler.])
fi
;;
dgux*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD='${CC} -G'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
| > > > > > > | 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
], [],
ac_cv_cygwin=no,
ac_cv_cygwin=yes)
)
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
if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde14.dll" -a ! -f "../win/tk86.dll"; then
AC_MSG_ERROR([Please configure and make the ../win directory first.])
fi
;;
dgux*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD='${CC} -G'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
|
| ︙ | ︙ | |||
1958 1959 1960 1961 1962 1963 1964 | #-------------------------------------------------------------------- # On Solaris 5.x i386 with the sunpro compiler we need to link # with sunmath to get floating point rounding control #-------------------------------------------------------------------- AS_IF([test "$GCC" = yes],[use_sunmath=no],[ arch=`isainfo` AC_MSG_CHECKING([whether to use -lsunmath for fp rounding control]) | | | 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 | #-------------------------------------------------------------------- # On Solaris 5.x i386 with the sunpro compiler we need to link # with sunmath to get floating point rounding control #-------------------------------------------------------------------- AS_IF([test "$GCC" = yes],[use_sunmath=no],[ arch=`isainfo` AC_MSG_CHECKING([whether to use -lsunmath for fp rounding control]) AS_IF([test "$arch" = "amd64 i386" -o "$arch" = "i386"], [ AC_MSG_RESULT([yes]) MATH_LIBS="-lsunmath $MATH_LIBS" AC_CHECK_HEADER(sunmath.h) use_sunmath=yes ], [ AC_MSG_RESULT([no]) use_sunmath=no |
| ︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 | ], [AS_IF([test "$arch" = "amd64 i386"], [ SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" ])]) ]) ], [ AS_IF([test "$use_sunmath" = yes], [textmode=textoff],[textmode=text]) case $system in | | | 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 |
], [AS_IF([test "$arch" = "amd64 i386"], [
SHLIB_LD="$SHLIB_LD -m64 -static-libgcc"
])])
])
], [
AS_IF([test "$use_sunmath" = yes], [textmode=textoff],[textmode=text])
case $system in
SunOS-5.[[1-9]][[0-9]]*|SunOS-5.[[7-9]])
SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";;
*)
SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";;
esac
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
])
|
| ︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 |
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
UNSHARED_LIB_SUFFIX='${VERSION}.a'])
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
| | | | | | | | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 |
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
UNSHARED_LIB_SUFFIX='${VERSION}.a'])
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${TCL_SHLIB_LD_EXTRAS} ${SHLIB_LD_LIBS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
], [
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
])
], [
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
AS_IF([test "$RANLIB" = ""], [
MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
], [
MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)" ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(LIB_FILE))'
])
])
# Stub lib does not depend on shared/static configuration
AS_IF([test "$RANLIB" = ""], [
MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"'
], [
MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)" ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(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.
AS_IF([test "x${TCL_LIBS}" = x], [
TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"])
|
| ︙ | ︙ |
Changes to unix/tcl.spec.
1 2 3 4 5 6 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
Version: 8.6.0
Release: 2
License: BSD
Group: Development/Languages
Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz
URL: http://www.tcl.tk/
Buildroot: /var/tmp/%{name}%{version}
|
| ︙ | ︙ |
Changes to unix/tclConfig.h.in.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
/* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */
#ifndef _TCLCONFIG
#define _TCLCONFIG
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
/* Define to 1 if you have the <AvailabilityMacros.h> header file. */
#undef HAVE_AVAILABILITYMACROS_H
/* Define to 1 if the system has the type `blkcnt_t'. */
#undef HAVE_BLKCNT_T
| > > > | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
/* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */
#ifndef _TCLCONFIG
#define _TCLCONFIG
/* Define if building universal (internal helper macro) */
#undef AC_APPLE_UNIVERSAL_BUILD
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
/* Define to 1 if you have the <AvailabilityMacros.h> header file. */
#undef HAVE_AVAILABILITYMACROS_H
/* Define to 1 if the system has the type `blkcnt_t'. */
#undef HAVE_BLKCNT_T
/* Defined when compiler supports casting to union type. */
#undef HAVE_CAST_TO_UNION
/* Define to 1 if you have the `chflags' function. */
#undef HAVE_CHFLAGS
/* Define to 1 if you have the `copyfile' function. */
#undef HAVE_COPYFILE
/* Define to 1 if you have the <copyfile.h> header file. */
#undef HAVE_COPYFILE_H
/* Do we have access to Darwin CoreFoundation.framework? */
#undef HAVE_COREFOUNDATION
/* Is the cpuid instruction usable? */
#undef HAVE_CPUID
/* Define to 1 if you have the `freeaddrinfo' function. */
#undef HAVE_FREEADDRINFO
/* Do we have fts functions? */
#undef HAVE_FTS
|
| ︙ | ︙ | |||
201 202 203 204 205 206 207 | /* Define to 1 if the system has the type `struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in <sys/stat.h>? */ #undef HAVE_STRUCT_STAT64 | | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | /* Define to 1 if the system has the type `struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in <sys/stat.h>? */ #undef HAVE_STRUCT_STAT64 /* Define to 1 if `st_blksize' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE /* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the <sys/filio.h> header file. */ #undef HAVE_SYS_FILIO_H /* Define to 1 if you have the <sys/ioctl.h> header file. */ #undef HAVE_SYS_IOCTL_H |
| ︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 276 277 278 279 | #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Default libtommath precision. */ #undef MP_PREC /* Use compat implementation of getaddrinfo() and friends */ #undef NEED_FAKE_RFC2553 /* Is Darwin CoreFoundation unavailable for 64-bit? */ #undef NO_COREFOUNDATION_64 | > > > | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | #undef MAC_OSX_TCL /* 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 Darwin CoreFoundation unavailable for 64-bit? */ #undef NO_COREFOUNDATION_64 |
| ︙ | ︙ | |||
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 | #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* What encoding should be used for embedded configuration info? */ #undef TCL_CFGVAL_ENCODING | > > > < < < | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* What encoding should be used for embedded configuration info? */ #undef TCL_CFGVAL_ENCODING /* Is this a 64-bit build? */ #undef TCL_CFG_DO64BIT /* Is this an optimized build? */ #undef TCL_CFG_OPTIMIZED /* Is bytecode debugging enabled? */ |
| ︙ | ︙ | |||
435 436 437 438 439 440 441 | /* Do we want to use the threaded memory allocator? */ #undef USE_THREAD_ALLOC /* Should we use vfork() instead of fork()? */ #undef USE_VFORK | | | > > > > > > | > > | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 | /* Do we want to use the threaded memory allocator? */ #undef USE_THREAD_ALLOC /* Should we use vfork() instead of fork()? */ #undef USE_VFORK /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN # undef WORDS_BIGENDIAN # endif #endif /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE /* Add the _ISOC99_SOURCE flag when building */ #undef _ISOC99_SOURCE |
| ︙ | ︙ | |||
492 493 494 495 496 497 498 | /* Define to `int' if <sys/types.h> does not define. */ #undef mode_t /* Define to `int' if <sys/types.h> does not define. */ #undef pid_t | | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | /* Define to `int' if <sys/types.h> does not define. */ #undef mode_t /* Define to `int' if <sys/types.h> does not define. */ #undef pid_t /* Define to `unsigned int' if <sys/types.h> does not define. */ #undef size_t /* Define as int if socklen_t is not available */ #undef socklen_t /* Do we want to use the strtod() in compat? */ #undef strtod |
| ︙ | ︙ |
Changes to unix/tclConfig.sh.in.
1 | # tclConfig.sh -- | | | 1 2 3 4 5 6 7 8 9 | # tclConfig.sh -- # # This shell script (for sh) is generated automatically by Tcl's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. # This script is intended to be included by the configure scripts # for Tcl extensions so that they don't have to figure this all # out for themselves. # |
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > > | > > > > > > > > > > | | | > | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
void *handle;
Tcl_LoadHandle newHandle;
const char *native;
int dlopenflags = 0;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
}
if (flags & TCL_LOAD_LAZY) {
dlopenflags |= RTLD_LAZY;
} else {
dlopenflags |= RTLD_NOW;
}
handle = dlopen(native, dlopenflags);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
const char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
handle = dlopen(native, dlopenflags);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
const char *errorStr = dlerror();
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
Tcl_GetString(pathPtr), errorStr));
return TCL_ERROR;
}
newHandle = ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
Tcl_Interp *interp, /* Place to put error messages. */
Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */
const char *symbol) /* Symbol to look up. */
{
const char *native; /* Name of the library to be loaded, in
* system encoding */
Tcl_DString newName, ds; /* Buffers for converting the name to
| | | > | > > > | > | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
Tcl_Interp *interp, /* Place to put error messages. */
Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */
const char *symbol) /* Symbol to look up. */
{
const char *native; /* Name of the library to be loaded, in
* system encoding */
Tcl_DString newName, ds; /* Buffers for converting the name to
* system encoding and prepending an
* underscore*/
void *handle = (void *) loadHandle->clientData;
/* Native handle to the loaded library */
void *proc; /* Address corresponding to the resolved
* symbol */
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again with
* the underscore.
*/
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
proc = dlsym(handle, native); /* INTL: Native. */
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
if (proc == NULL && interp != NULL) {
const char *errorStr = dlerror();
if (!errorStr) {
errorStr = "unknown";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errorStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
return proc;
}
/*
|
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * 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 MODULE_SCOPE | | < | > > | | | | | < | < < < < | | < < < | > | < | | < < < | | < < < < < < < < < < < < > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
* 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 MODULE_SCOPE
# define MODULE_SCOPE extern
#endif
/*
* Use preferred dlfcn API on 10.4 and later
*/
#ifndef TCL_DYLD_USE_DLFCN
# ifdef NO_DLFCN_H
# define TCL_DYLD_USE_DLFCN 0
# else
# define TCL_DYLD_USE_DLFCN 1
# endif
#endif
/*
* Use deprecated NSModule API only to support 10.3 and earlier:
*/
#ifndef TCL_DYLD_USE_NSMODULE
# define TCL_DYLD_USE_NSMODULE 0
#endif
/*
* Use includes for the API we're using.
*/
#if TCL_DYLD_USE_DLFCN
# include <dlfcn.h>
#endif /* TCL_DYLD_USE_DLFCN */
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
#include <mach-o/dyld.h>
#include <mach-o/fat.h>
#include <mach-o/swap.h>
#include <mach-o/arch.h>
#include <libkern/OSByteOrder.h>
#include <mach/mach.h>
typedef struct Tcl_DyldModuleHandle {
struct Tcl_DyldModuleHandle *nextPtr;
NSModule module;
} Tcl_DyldModuleHandle;
#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
typedef struct {
void *dlHandle;
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader;
Tcl_DyldModuleHandle *modulePtr;
#endif
} Tcl_DyldLoadHandle;
#if TCL_DYLD_USE_DLFCN || defined(TCL_LOAD_FROM_MEMORY)
MODULE_SCOPE long tclMacOSXDarwinRelease;
#endif
/*
* Static functions defined in this file.
*/
static void * FindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, const char *symbol);
static void UnloadFile(Tcl_LoadHandle handle);
/*
*----------------------------------------------------------------------
*
* DyldOFIErrorMsg --
*
* Converts a numerical NSObjectFileImage error into an error message
* string.
*
* Results:
* Error message string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
static const char *
DyldOFIErrorMsg(
int err)
{
switch(err) {
case NSObjectFileImageSuccess:
return NULL;
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
return "bad object file format";
case NSObjectFileImageAccess:
return "can't read object file";
default:
return "unknown error";
}
}
| | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
return "bad object file format";
case NSObjectFileImageAccess:
return "can't read object file";
default:
return "unknown error";
}
}
#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
/*
*----------------------------------------------------------------------
*
* TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns a handle
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > < < | < > > > > > < < < < | > > > > > > > > > > > | | | | | | | < < < < < | < | < < < < | > | < < < < < < < | < < < | | > | < < < < < < | < | < | < < | > | > > > > | | | > | | < | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
Tcl_DyldLoadHandle *dyldLoadHandle;
Tcl_LoadHandle newHandle;
void *dlHandle = NULL;
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader = NULL;
Tcl_DyldModuleHandle *modulePtr = NULL;
#endif
#if TCL_DYLD_USE_NSMODULE
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *objFileImageErrMsg = NULL;
#endif /* TCL_DYLD_USE_NSMODULE */
const char *errMsg = NULL;
int result;
Tcl_DString ds;
const char *nativePath, *nativeFileName = NULL;
#if TCL_DYLD_USE_DLFCN
int dlopenflags = 0;
#endif /* TCL_DYLD_USE_DLFCN */
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr),
-1, &ds);
#if TCL_DYLD_USE_DLFCN
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
}
if (flags & TCL_LOAD_LAZY) {
dlopenflags |= RTLD_LAZY;
} else {
dlopenflags |= RTLD_NOW;
}
dlHandle = dlopen(nativePath, dlopenflags);
if (!dlHandle) {
/*
* Let the OS loader examine the binary search path for whatever string
* the user gave us which hopefully refers to a file on the binary
* path.
*/
dlHandle = dlopen(nativeFileName, dlopenflags);
if (!dlHandle) {
errMsg = dlerror();
}
}
#endif /* TCL_DYLD_USE_DLFCN */
if (!dlHandle) {
#if TCL_DYLD_USE_NSMODULE
dyldLibHeader = NSAddImage(nativePath,
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
if (!dyldLibHeader) {
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
if (editError == NSLinkEditFileAccessError) {
/*
* The requested file was not found. Let the OS loader examine
* the binary search path for whatever string the user gave us
* which hopefully refers to a file on the binary path.
*/
dyldLibHeader = NSAddImage(nativeFileName,
NSADDIMAGE_OPTION_WITH_SEARCHING |
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
if (!dyldLibHeader) {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
}
} else if ((editError == NSLinkEditFileFormatError
&& errorNumber == EBADMACHO)
|| editError == NSLinkEditOtherError){
NSObjectFileImageReturnCode err;
NSObjectFileImage dyldObjFileImage;
NSModule module;
/*
* The requested file was found but was not of type MH_DYLIB,
* attempt to load it as a MH_BUNDLE.
*/
err = NSCreateObjectFileImageFromFile(nativePath,
&dyldObjFileImage);
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
}
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
if (dlHandle
#if TCL_DYLD_USE_NSMODULE
|| dyldLibHeader || modulePtr
#endif /* TCL_DYLD_USE_NSMODULE */
) {
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->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
result = TCL_OK;
} else {
Tcl_Obj *errObj = Tcl_NewObj();
if (errMsg != NULL) {
Tcl_AppendToObj(errObj, errMsg, -1);
}
#if TCL_DYLD_USE_NSMODULE
if (objFileImageErrMsg) {
Tcl_AppendPrintfToObj(errObj,
"\nNSCreateObjectFileImageFromFile() error: %s",
objFileImageErrMsg);
}
#endif /* TCL_DYLD_USE_NSMODULE */
Tcl_SetObjResult(interp, errObj);
result = TCL_ERROR;
}
Tcl_DStringFree(&ds);
return result;
}
/*
*----------------------------------------------------------------------
*
* FindSymbol --
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 |
Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
Tcl_PackageInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
| < > | < < < < < > | < < > | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
Tcl_PackageInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
proc = dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
Tcl_DString newName;
/*
* dyld adds an underscore to the beginning of symbol names.
*/
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
if (dyldLoadHandle->dyldLibHeader) {
nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader,
native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
if (nsSymbol) {
/*
* Until dyld supports unloading of MY_DYLIB binaries, the
* following is not needed.
*/
#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING
NSModule module = NSModuleForSymbol(nsSymbol);
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
| < < < < < < < < < < < | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
}
} else if (dyldLoadHandle->modulePtr) {
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
proc = NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
}
Tcl_DStringFree(&ds);
if (errMsg && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errMsg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
return proc;
}
/*
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
| < < | | | < | < < < < < | < | < < < < < < | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 |
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = loadHandle->clientData;
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
(void) dlclose(dyldLoadHandle->dlHandle);
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
void *ptr = modulePtr;
(void) NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
modulePtr = modulePtr->nextPtr;
ckfree(ptr);
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
ckfree(dyldLoadHandle);
ckfree(loadHandle);
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 |
* translated to local form if needed). */
Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
* name to this if possible. */
{
return 0;
}
| < > | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
* translated to local form if needed). */
Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
* name to this if possible. */
{
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclpLoadMemoryGetBuffer --
*
* Allocate a buffer that can be used with TclpLoadMemory() below.
*
* Results:
* Pointer to allocated buffer or NULL if an error occurs.
*
* Side effects:
* Buffer is allocated.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
Tcl_Interp *interp, /* Used for error reporting. */
int size) /* Size of desired buffer. */
{
void *buffer = NULL;
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) {
buffer = NULL;
}
}
return buffer;
}
/*
*----------------------------------------------------------------------
*
* TclpLoadMemory --
*
* Dynamically loads binary code file from memory and returns a handle to
* the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error message
* is left in the interpreter's result.
*
* Side effects:
* New code is loaded from memory.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
void *buffer, /* Buffer containing the desired code
* (allocated with TclpLoadMemoryGetBuffer). */
int size, /* Allocation size of buffer. */
int codeSize, /* Size of code data read into buffer or -1 if
* an error occurred and the buffer should
* just be freed. */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| > > | > > | < < < < < < | < < < < < | < < < < < > | | > > | < | < < < | < < | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) {
buffer = NULL;
}
}
return buffer;
}
#endif /* TCL_LOAD_FROM_MEMORY */
/*
*----------------------------------------------------------------------
*
* TclpLoadMemory --
*
* Dynamically loads binary code file from memory and returns a handle to
* the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error message
* is left in the interpreter's result.
*
* Side effects:
* New code is loaded from memory.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
void *buffer, /* Buffer containing the desired code
* (allocated with TclpLoadMemoryGetBuffer). */
int size, /* Allocation size of buffer. */
int codeSize, /* Size of code data read into buffer or -1 if
* an error occurred and the buffer should
* just be freed. */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
Tcl_DyldLoadHandle *dyldLoadHandle;
NSObjectFileImage dyldObjFileImage = NULL;
Tcl_DyldModuleHandle *modulePtr;
NSModule module;
const char *objFileImageErrMsg = NULL;
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
const struct fat_header *fh = buffer;
uint32_t ms = 0;
#ifndef __LP64__
const struct mach_header *mh = NULL;
# define mh_size sizeof(struct mach_header)
# define mh_magic MH_MAGIC
# define arch_abi 0
#else
const struct mach_header_64 *mh = NULL;
# define mh_size sizeof(struct mach_header_64)
# define mh_magic MH_MAGIC_64
# define arch_abi CPU_ARCH_ABI64
#endif /* __LP64__ */
if ((size_t) codeSize >= sizeof(struct fat_header)
&& fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) {
uint32_t fh_nfat_arch = OSSwapBigToHostInt32(fh->nfat_arch);
/*
* Fat binary, try to find mach_header for our architecture
*/
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char*)buffer + sizeof(struct fat_header);
const NXArchInfo *arch = NXGetLocalArchInfo();
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
}
fa = NXFindBestFatArch(arch->cputype | arch_abi,
arch->cpusubtype, fatarchs, fh_nfat_arch);
if (fa) {
mh = (void *)((char *) buffer + fa->offset);
ms = fa->size;
} else {
err = NSObjectFileImageInappropriateFile;
}
if (fh->magic != FAT_MAGIC) {
swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
}
} else {
err = NSObjectFileImageInappropriateFile;
}
} else {
/*
* Thin binary
*/
mh = buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == MH_BUNDLE)) {
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
err = NSCreateObjectFileImageFromMemory(buffer, codeSize,
&dyldObjFileImage);
if (err != NSObjectFileImageSuccess) {
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
}
/*
* If it went wrong (or we were asked to just deallocate), get rid of the
* memory block and create an error message.
*/
if (dyldObjFileImage == NULL) {
vm_deallocate(mach_task_self(), (vm_address_t) buffer, size);
if (objFileImageErrMsg != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"NSCreateObjectFileImageFromMemory() error: %s",
objFileImageErrMsg));
}
return TCL_ERROR;
}
/*
* Extract the module we want from the image of the object file.
*/
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]", nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (!module) {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *errMsg;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = NULL;
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
newHandle = ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | #include "tclInt.h" #include <mach-o/rld.h> #include <streams/streams.h> /* Static procedures defined within this file */ | | | | < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | #include "tclInt.h" #include <mach-o/rld.h> #include <streams/streams.h> /* Static procedures defined within this file */ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char* symbol); static void UnloadFile(Tcl_LoadHandle loadHandle); /* *---------------------------------------------------------------------- * * TclpDlopen -- * * Dynamically loads a binary code file into memory and returns a handle |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
struct mach_header *header;
char *fileName;
char *files[2];
const char *native;
int result = 1;
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
Tcl_DStringFree(&ds);
}
if (!result) {
char *data;
int len, maxlen;
| | | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
Tcl_DStringFree(&ds);
}
if (!result) {
char *data;
int len, maxlen;
NXGetMemoryBuffer(errorStream, &data, &len, &maxlen);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
newHandle = ckalloc(sizeof(Tcl_LoadHandle));
newHandle->clientData = INT2PTR(1);
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | * Returns a pointer to the function associated with 'symbol' if it is * found. Otherwise returns NULL and may leave an error message in the * interp's result. * *---------------------------------------------------------------------- */ | | > | | | < | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 |
* Returns a pointer to the function associated with 'symbol' if it is
* found. Otherwise returns NULL and may leave an error message in the
* interp's result.
*
*----------------------------------------------------------------------
*/
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
Tcl_PackageInitProc *proc = NULL;
if (symbol) {
char sym[strlen(symbol) + 2];
sym[0] = '_';
sym[1] = 0;
strcat(sym, symbol);
rld_lookup(NULL, sym, (unsigned long *) &proc);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
return proc;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | * 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 <sys/types.h> #include <loader.h> | | > | > | | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | * 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 <sys/types.h> #include <loader.h> /* * Static functions defined within this file. */ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char* symbol); static void UnloadFile(Tcl_LoadHandle handle); /* *---------------------------------------------------------------------- * * TclpDlopen -- * * Dynamically loads a binary code file into memory and returns a handle |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
ldr_module_t lm;
char *pkg;
char *fileName = Tcl_GetString(pathPtr);
const char *native;
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
Tcl_DStringFree(&ds);
}
if (lm == LDR_NULL_MODULE) {
| > | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
Tcl_DStringFree(&ds);
}
if (lm == LDR_NULL_MODULE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
*clientDataPtr = NULL;
/*
* My convention is to use a [OSF loader] package name the same as shlib,
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
| | > | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
void *retval = ldr_lookup_package((char *) loadHandle, symbol);
if (retval == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
return retval;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/tclLoadShl.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 | * 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 <dl.h> /* | > | < < < | < < < < | < < | < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * 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 <dl.h> #include "tclInt.h" /* * Static functions defined within this file. */ static void * FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void UnloadFile(Tcl_LoadHandle handle); /* *---------------------------------------------------------------------- * * TclpDlopen -- * * Dynamically loads a binary code file into memory and returns a handle |
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
shl_t handle;
Tcl_LoadHandle newHandle;
const char *native;
char *fileName = Tcl_GetString(pathPtr);
/*
|
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
| > | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 |
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
newHandle = ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
Tcl_DString newName;
Tcl_PackageInitProc *proc = NULL;
| | | | | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
Tcl_DString newName;
Tcl_PackageInitProc *proc = NULL;
shl_t handle = (shl_t) loadHandle->clientData;
/*
* Some versions of the HP system software still use "_" at the beginning
* of exported symbols while others don't; try both forms of each name.
*/
if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
(void *) &proc) != 0) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
Tcl_DStringAppend(&newName, symbol, -1);
if (shl_findsym(&handle, Tcl_DStringValue(&newName),
(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
proc = NULL;
}
Tcl_DStringFree(&newName);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s",
symbol, Tcl_PosixError(interp)));
}
return proc;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | < | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
int data;
int stop;
} TtyAttrs;
#endif /* !SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
| | | | | | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
int data;
int stop;
} TtyAttrs;
#endif /* !SUPPORTS_TTY */
#define UNSUPPORTED_OPTION(detail) \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s not supported for this platform", (detail))); \
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
/*
* Static routines for this file:
*/
static int FileBlockModeProc(ClientData instanceData, int mode);
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 |
return TCL_ERROR;
#endif /* CRTSCTS */
} else if (strncasecmp(value, "DTRDSR", vlen) == 0) {
UNSUPPORTED_OPTION("-handshake DTRDSR");
return TCL_ERROR;
} else {
if (interp) {
| > | | < > | | | | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
return TCL_ERROR;
#endif /* CRTSCTS */
} else if (strncasecmp(value, "DTRDSR", vlen) == 0) {
UNSUPPORTED_OPTION("-handshake DTRDSR");
return TCL_ERROR;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -handshake: must be one of"
" xonxoff, rtscts, dtrdsr or none", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
return TCL_ERROR;
}
SETIOSTATE(fsPtr->fd, &iostate);
return TCL_OK;
}
/*
* Option -xchar {\x11 \x13}
*/
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) {
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);
}
ckfree(argv);
return TCL_ERROR;
}
GETIOSTATE(fsPtr->fd, &iostate);
Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds);
iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds);
TclDStringClear(&ds);
Tcl_UtfToExternalDString(NULL, argv[1], -1, &ds);
iostate.c_cc[VSTOP] = *(const cc_t *) Tcl_DStringValue(&ds);
Tcl_DStringFree(&ds);
ckfree(argv);
SETIOSTATE(fsPtr->fd, &iostate);
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
int i;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp) {
| > | | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 |
int i;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
#else /* !SETBREAK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
ckfree(argv);
return TCL_ERROR;
#endif /* SETBREAK */
} else {
if (interp) {
| | | | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
#else /* !SETBREAK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
ckfree(argv);
return TCL_ERROR;
#endif /* SETBREAK */
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
} /* -ttycontrol options loop */
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 | valid = 1; GETIOSTATE(fsPtr->fd, &iostate); Tcl_DStringInit(&ds); Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); | | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 |
valid = 1;
GETIOSTATE(fsPtr->fd, &iostate);
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds);
Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
TclDStringClear(&ds);
Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds);
Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
}
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
|
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 |
char parity;
static const char *bad = "bad value for -mode";
i = sscanf(mode, "%d,%c,%d,%d%n", speedPtr, &parity, dataPtr,
stopPtr, &end);
if ((i != 4) || (mode[end] != '\0')) {
if (interp != NULL) {
| > | < | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
char parity;
static const char *bad = "bad value for -mode";
i = sscanf(mode, "%d,%c,%d,%d%n", speedPtr, &parity, dataPtr,
stopPtr, &end);
if ((i != 4) || (mode[end] != '\0')) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s: should be baud,parity,data,stop", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
/*
* Only allow setting mark/space parity on platforms that support it Make
|
| ︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 |
#if defined(PAREXT) || defined(USE_TERMIO)
strchr("noems", parity)
#else
strchr("noe", parity)
#endif /* PAREXT|USE_TERMIO */
== NULL) {
if (interp != NULL) {
| > | | | | > | < > | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 |
#if defined(PAREXT) || defined(USE_TERMIO)
strchr("noems", parity)
#else
strchr("noe", parity)
#endif /* PAREXT|USE_TERMIO */
== NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s parity: should be %s", bad,
#if defined(PAREXT) || defined(USE_TERMIO)
"n, o, e, m, or s"
#else
"n, o, or e"
#endif /* PAREXT|USE_TERMIO */
));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
*parityPtr = parity;
if ((*dataPtr < 5) || (*dataPtr > 8)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s data: should be 5, 6, 7, or 8", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
if ((*stopPtr < 0) || (*stopPtr > 2)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s stop: should be 1 or 2", bad));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 |
SET_BITS(mode, O_BINARY);
#endif
fd = TclOSopen(native, mode, permissions);
if (fd < 0) {
if (interp != NULL) {
| > | | | 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 |
SET_BITS(mode, O_BINARY);
#endif
fd = TclOSopen(native, mode, permissions);
if (fd < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
|
| ︙ | ︙ | |||
1838 1839 1840 1841 1842 1843 1844 |
ClientData data;
FILE *f;
chan = Tcl_GetChannel(interp, chanID, &chanMode);
if (chan == NULL) {
return TCL_ERROR;
}
| | > | < | > | < | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 |
ClientData data;
FILE *f;
chan = Tcl_GetChannel(interp, chanID, &chanMode);
if (chan == NULL) {
return TCL_ERROR;
}
if (forWriting && !(chanMode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" wasn't opened for writing", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE",
NULL);
return TCL_ERROR;
} else if (!forWriting && !(chanMode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" wasn't opened for reading", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE",
NULL);
return TCL_ERROR;
}
/*
* We allow creating a FILE * out of file based, pipe based and socket
|
| ︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 |
* The call to fdopen below is probably dangerous, since it will
* truncate an existing file if the file is being opened for
* writing....
*/
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
| > | < | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 |
* The call to fdopen below is probably dangerous, since it will
* truncate an existing file if the file is being opened for
* writing....
*/
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot get a FILE * for \"%s\"", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL",
"FILE_FAILURE", NULL);
return TCL_ERROR;
}
*filePtr = f;
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" cannot be used to get a FILE *", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR",
NULL);
return TCL_ERROR;
}
#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is
* in tclMacOSXNotify.c */
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 101 102 103 | */ #undef NEED_COPYARRAY #undef NEED_COPYGRP #undef NEED_COPYHOSTENT #undef NEED_COPYPWD #undef NEED_COPYSTRING static int CopyArray(char **src, int elsize, char *buf, int buflen); | > > > > > > > > > > < < | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | */ #undef NEED_COPYARRAY #undef NEED_COPYGRP #undef NEED_COPYHOSTENT #undef NEED_COPYPWD #undef NEED_COPYSTRING #if !defined(HAVE_GETGRNAM_R_5) && !defined(HAVE_GETGRNAM_R_4) #define NEED_COPYGRP 1 static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); #endif #if !defined(HAVE_GETPWNAM_R_5) && !defined(HAVE_GETPWNAM_R_4) #define NEED_COPYPWD 1 static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); #endif static int CopyArray(char **src, int elsize, char *buf, int buflen); static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER static void FreePwBuf(ClientData ignored); #endif |
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWNAM_R_4)
return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
| < | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWNAM_R_4)
return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
struct passwd *pwPtr;
Tcl_MutexLock(&compatLock);
pwPtr = getpwnam(name);
if (pwPtr != NULL) {
tsdPtr->pwd = *pwPtr;
pwPtr = &tsdPtr->pwd;
|
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWUID_R_4)
return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
| < | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 |
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWUID_R_4)
return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
struct passwd *pwPtr;
Tcl_MutexLock(&compatLock);
pwPtr = getpwuid(uid);
if (pwPtr != NULL) {
tsdPtr->pwd = *pwPtr;
pwPtr = &tsdPtr->pwd;
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 |
const char *name)
{
#if !defined(TCL_THREADS)
return getgrnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
const char *name)
{
#if !defined(TCL_THREADS)
return getgrnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETGRNAM_R_5)
struct group *grPtr = NULL;
/*
* How to allocate a buffer of the right initial size. If you want the
* gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
* and weep.
*/
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRNAM_R_4)
return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
| < | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRNAM_R_4)
return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
struct group *grPtr;
Tcl_MutexLock(&compatLock);
grPtr = getgrnam(name);
if (grPtr != NULL) {
tsdPtr->grp = *grPtr;
grPtr = &tsdPtr->grp;
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 |
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRGID_R_4)
return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
| < | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRGID_R_4)
return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
struct group *grPtr;
Tcl_MutexLock(&compatLock);
grPtr = getgrgid(gid);
if (grPtr != NULL) {
tsdPtr->grp = *grPtr;
grPtr = &tsdPtr->grp;
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | * 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. */ #include "tclInt.h" #include <utime.h> #include <grp.h> #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif | > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | * 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. */ #include <sys/stat.h> #include "tclInt.h" #include <utime.h> #include <grp.h> #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 | * TraverseUnixTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ #define DOTREE_POSTD 2 /* post-order directory */ #define DOTREE_F 3 /* regular file */ /* * Callbacks for file attributes code. */ static int GetGroupAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); static int GetOwnerAttribute(Tcl_Interp *interp, int objIndex, | > > > > > > > > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | * TraverseUnixTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ #define DOTREE_POSTD 2 /* post-order directory */ #define DOTREE_F 3 /* regular file */ /* * Fallback temporary file location the temporary file generation code. Can be * overridden at compile time for when it is known that temp files can't be * written to /tmp (hello, iOS!). */ #ifndef TCL_TEMPORARY_FILE_DIRECTORY #define TCL_TEMPORARY_FILE_DIRECTORY "/tmp" #endif /* * Callbacks for file attributes code. */ static int GetGroupAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); static int GetOwnerAttribute(Tcl_Interp *interp, int objIndex, |
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
result = traverseProc(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
errorPtr);
if (result != TCL_OK) {
closedir(dirPtr);
return result;
}
| | | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 |
result = traverseProc(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
errorPtr);
if (result != TCL_OK) {
closedir(dirPtr);
return result;
}
TclDStringAppendLiteral(sourcePtr, "/");
sourceLen = Tcl_DStringLength(sourcePtr);
if (targetPtr != NULL) {
TclDStringAppendLiteral(targetPtr, "/");
targetLen = Tcl_DStringLength(targetPtr);
}
while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
if ((dirEntPtr->d_name[0] == '.')
&& ((dirEntPtr->d_name[1] == '\0')
|| (strcmp(dirEntPtr->d_name, "..") == 0))) {
|
| ︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 |
struct group *groupPtr;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
| > | | < | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 |
struct group *groupPtr;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 |
struct passwd *pwPtr;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
| > | | < | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 |
struct passwd *pwPtr;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
|
| ︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 |
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
| > | | < | 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 |
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
*attributePtrPtr = Tcl_ObjPrintf(
"%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));
return TCL_OK;
|
| ︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 |
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (groupPtr == NULL) {
if (interp != NULL) {
| > | > | < > | | < | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 |
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (groupPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\":"
" group \"%s\" does not exist",
TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP",
"NO_GROUP", NULL);
}
return TCL_ERROR;
}
gid = groupPtr->gr_gid;
}
native = Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
if (interp != NULL) {
| > | > | < > | | < | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 |
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\":"
" user \"%s\" does not exist",
TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN",
"NO_USER", NULL);
}
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
native = Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1626 1627 1628 1629 1630 1631 1632 |
* We get the current mode of the file, in order to allow for ug+-=rwx
* style chmod strings.
*/
result = TclpObjStat(fileName, &buf);
if (result != 0) {
if (interp != NULL) {
| > | | < > | | > | | < | 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
* We get the current mode of the file, in order to allow for ug+-=rwx
* style chmod strings.
*/
result = TclpObjStat(fileName, &buf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
newMode = (mode_t) (buf.st_mode & 0x00007FFF);
if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown permission string format \"%s\"",
modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
}
return TCL_ERROR;
}
}
native = Tcl_FSGetNativePath(fileName);
result = chmod(native, newMode); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set permissions for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
#ifndef DJGPP
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 |
return nextCheckpoint;
}
/*
*----------------------------------------------------------------------
*
| | | > > > > > > > | > > > > > > > > > > > > > > > > > | | | | | > | | | | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 |
return nextCheckpoint;
}
/*
*----------------------------------------------------------------------
*
* TclpOpenTemporaryFile, TclUnixOpenTemporaryFile --
*
* Creates a temporary file, possibly based on the supplied bits and
* pieces of template supplied in the first three arguments. If the
* fourth argument is non-NULL, it contains a Tcl_Obj to store the name
* of the temporary file in (and it is caller's responsibility to clean
* up). If the fourth argument is NULL, try to arrange for the temporary
* file to go away once it is no longer needed.
*
* Results:
* A read-write Tcl Channel open on the file for TclpOpenTemporaryFile,
* or a file descriptor (or -1 on failure) for TclUnixOpenTemporaryFile.
*
* Side effects:
* Accesses the filesystem. Will set the contents of the Tcl_Obj fourth
* argument (if that is non-NULL).
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
int fd = TclUnixOpenTemporaryFile(dirObj, basenameObj, extensionObj,
resultingNameObj);
if (fd == -1) {
return NULL;
}
return Tcl_MakeFileChannel(INT2PTR(fd), TCL_READABLE|TCL_WRITABLE);
}
int
TclUnixOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
Tcl_DString template, tmp;
const char *string;
int len, 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);
} else {
Tcl_DStringInit(&template);
Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */
}
TclDStringAppendLiteral(&template, "/");
if (basenameObj) {
string = Tcl_GetStringFromObj(basenameObj, &len);
Tcl_UtfToExternalDString(NULL, string, len, &tmp);
TclDStringAppendDString(&template, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&template, "tcl");
}
TclDStringAppendLiteral(&template, "_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));
Tcl_DStringFree(&tmp);
} else
#endif
{
fd = mkstemp(Tcl_DStringValue(&template));
}
if (fd == -1) {
Tcl_DStringFree(&template);
return -1;
}
if (resultingNameObj) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template),
Tcl_DStringLength(&template), &tmp);
Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp),
Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else {
/*
* Try to delete the file immediately since we're not reporting the
* name to anyone. Note that we're *not* handling any errors from
* this!
*/
unlink(Tcl_DStringValue(&template));
errno = 0;
}
Tcl_DStringFree(&template);
return fd;
}
/*
* Helper that does *part* of what tempnam() does.
*/
static const char *
|
| ︙ | ︙ | |||
2196 2197 2198 2199 2200 2201 2202 |
dir = P_tmpdir;
if (stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)) {
return dir;
}
#endif
/*
| > | | | | 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 |
dir = P_tmpdir;
if (stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)) {
return dir;
}
#endif
/*
* Assume that the default location ("/tmp" if not overridden) is always
* an existing writable directory; we've no recovery mechanism if it
* isn't.
*/
return TCL_TEMPORARY_FILE_DIRECTORY;
}
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
*----------------------------------------------------------------------
*
* GetReadOnlyAttribute
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 |
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
| > | | < | | 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 |
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2282 2283 2284 2285 2286 2287 2288 |
return TCL_ERROR;
}
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
| > | | < > | | < | 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 |
return TCL_ERROR;
}
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
if (readonly) {
statBuf.st_flags |= UF_IMMUTABLE;
} else {
statBuf.st_flags &= ~UF_IMMUTABLE;
}
native = Tcl_FSGetNativePath(fileName);
result = chflags(native, statBuf.st_flags); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set flags for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
#endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */
|
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, const char* nativeName, Tcl_GlobTypeData *types); /* | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <sys/stat.h> #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, const char* nativeName, Tcl_GlobTypeData *types); /* |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
#ifdef __CYGWIN__
int length;
| | | < | | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
#ifdef __CYGWIN__
int length;
char buf[PATH_MAX * 2];
char name[PATH_MAX * TCL_UTF_MAX + 1];
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
/* Strip '.exe' part. */
length -= 4;
}
encoding = Tcl_GetEncoding(NULL, NULL);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), encoding);
#else
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
if (argv0 == NULL) {
return;
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
while (TclIsSpaceProc(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
| | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
while (TclIsSpaceProc(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
TclDStringClear(&buffer);
if (p != name) {
Tcl_DStringAppend(&buffer, name, p - name);
if (p[-1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
}
name = Tcl_DStringAppend(&buffer, argv0, -1);
/*
* INTL: The following calls to access() and stat() should not be
* converted to Tclp routines because they need to operate on native
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
TclpGetCwd(NULL, &cwd);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), &buffer);
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
| | | < | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
TclpGetCwd(NULL, &cwd);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), &buffer);
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 |
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
| | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
dirName = TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
| | | | < | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
nativeDirLen = Tcl_DStringLength(&ds);
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 | ((types->perm & TCL_GLOB_PERM_W) && (access(nativeEntry, W_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_X) && (access(nativeEntry, X_OK) != 0)) #ifndef MAC_OSX_TCL || ((types->perm & TCL_GLOB_PERM_HIDDEN) && (*nativeName != '.')) | | | | | | < < | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 |
((types->perm & TCL_GLOB_PERM_W) &&
(access(nativeEntry, W_OK) != 0)) ||
((types->perm & TCL_GLOB_PERM_X) &&
(access(nativeEntry, X_OK) != 0))
#ifndef MAC_OSX_TCL
|| ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
(*nativeName != '.'))
#endif /* MAC_OSX_TCL */
) {
return 0;
}
}
if (types->type != 0) {
if (types->perm == 0) {
/*
* We haven't yet done a stat on the file.
*/
if (TclOSstat(nativeEntry, &buf) != 0) {
/*
* Posix error occurred. The only ok case is if this is a link
* to a nonexistent file, and the user did 'glob -l'. So we
* check that here:
*/
if ((types->type & TCL_GLOB_TYPE_LINK)
&& (TclOSlstat(nativeEntry, &buf) == 0)
&& S_ISLNK(buf.st_mode)) {
return 1;
}
return 0;
}
}
/*
* In order bcdpsfl as in 'find -t'
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 |
#endif /* S_ISSOCK */
((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))) {
/*
* Do nothing - this file is ok.
*/
} else {
#ifdef S_ISLNK
| | | | | < < | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
#endif /* S_ISSOCK */
((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode))) {
/*
* Do nothing - this file is ok.
*/
} else {
#ifdef S_ISLNK
if ((types->type & TCL_GLOB_TYPE_LINK)
&& (TclOSlstat(nativeEntry, &buf) == 0)
&& S_ISLNK(buf.st_mode)) {
goto filetypeOK;
}
#endif /* S_ISLNK */
return 0;
}
}
filetypeOK:
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
if (getwd(buffer) == NULL) { /* INTL: Native. */
return NULL;
}
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
| | | | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 |
if (getwd(buffer) == NULL) { /* INTL: Native. */
return NULL;
}
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
char *newCd = ckalloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
return newCd;
}
/*
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
{
char buffer[MAXPATHLEN+1];
#ifdef USEGETWD
if (getwd(buffer) == NULL) /* INTL: Native. */
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */
| | | | | | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
{
char buffer[MAXPATHLEN+1];
#ifdef USEGETWD
if (getwd(buffer) == NULL) /* INTL: Native. */
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */
#endif /* USEGETWD */
{
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr);
}
/*
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
#else
return NULL;
| | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
#else
return NULL;
#endif /* !DJGPP */
}
/*
*----------------------------------------------------------------------
*
* TclpObjStat --
*
|
| ︙ | ︙ | |||
856 857 858 859 860 861 862 |
return -1;
}
return TclOSstat(path, bufPtr);
}
#ifdef S_IFLNK
| | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
return -1;
}
return TclOSstat(path, bufPtr);
}
#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
const char *src = Tcl_FSGetNativePath(pathPtr);
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 1185 |
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
return utime(Tcl_FSGetNativePath(pathPtr), tval);
}
#ifdef __CYGWIN__
| > > > > > | > > > > > > | > > | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 |
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
return utime(Tcl_FSGetNativePath(pathPtr), tval);
}
#ifdef __CYGWIN__
int
TclOSstat(
const char *name,
Tcl_StatBuf *statBuf)
{
struct stat buf;
int result = stat(name, &buf);
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
statBuf->st_rdev = buf.st_rdev;
statBuf->st_nlink = buf.st_nlink;
statBuf->st_uid = buf.st_uid;
statBuf->st_gid = buf.st_gid;
statBuf->st_size = buf.st_size;
statBuf->st_atime = buf.st_atime;
statBuf->st_mtime = buf.st_mtime;
statBuf->st_ctime = buf.st_ctime;
return result;
}
int
TclOSlstat(
const char *name,
Tcl_StatBuf *statBuf)
{
struct stat buf;
int result = lstat(name, &buf);
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
statBuf->st_rdev = buf.st_rdev;
statBuf->st_nlink = buf.st_nlink;
statBuf->st_uid = buf.st_uid;
statBuf->st_gid = buf.st_gid;
statBuf->st_size = buf.st_size;
statBuf->st_atime = buf.st_atime;
statBuf->st_mtime = buf.st_mtime;
statBuf->st_ctime = buf.st_ctime;
return result;
}
#endif /* CYGWIN */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixInit.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. */ #include "tclInt.h" #include <stddef.h> #include <locale.h> #ifdef HAVE_LANGINFO # include <langinfo.h> # ifdef __APPLE__ # if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030 | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. */ #include <sys/stat.h> #include "tclInt.h" #include <stddef.h> #include <locale.h> #ifdef HAVE_LANGINFO # include <langinfo.h> # ifdef __APPLE__ # if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030 |
| ︙ | ︙ |
Changes to unix/tclUnixNotfy.c.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 |
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. */
Tcl_Condition waitCV; /* Any other thread alerts a notifier that an
* event is ready to be processed by signaling
* this condition variable. */
int eventReady; /* True if an event is ready to be processed.
* Used as condition flag together with waitCV
* above. */
| > > > > > > > | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
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
Tcl_Condition waitCV; /* Any other thread alerts a notifier that an
* event is ready to be processed by signaling
* this condition variable. */
#endif /* __CYGWIN__ */
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
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 183 184 185 186 187 188 189 | * Static routines defined in this file. */ #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); #endif static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- * * Initializes the platform specific notifier state. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
* Static routines defined in this file.
*/
#ifdef TCL_THREADS
static void NotifierThreadProc(ClientData clientData);
#endif
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
* Import of Windows API when building threaded with Cygwin.
*/
#if defined(TCL_THREADS) && defined(__CYGWIN__)
typedef struct {
void *hwnd;
unsigned int *message;
int wParam;
int lParam;
int time;
int x;
int y;
} MSG;
typedef struct {
unsigned int style;
void *lpfnWndProc;
int cbClsExtra;
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
void *lpszMenuName;
void *lpszClassName;
} WNDCLASS;
extern void __stdcall CloseHandle(void *);
extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
void *);
extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int,
int, int, int, void *, void *, void *, void *);
extern DWORD __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(DWORD, void *,
unsigned char, DWORD, DWORD);
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 WNDCLASS *);
extern unsigned char __stdcall ResetEvent(void *);
extern unsigned char __stdcall TranslateMessage(const MSG *);
/*
* Threaded-cygwin specific functions in this file:
*/
static DWORD __stdcall NotifierProc(void *hwnd, unsigned int message,
void *wParam, void *lParam);
#endif /* TCL_THREADS && __CYGWIN__ */
/*
*----------------------------------------------------------------------
*
* Tcl_InitNotifier --
*
* Initializes the platform specific notifier state.
|
| ︙ | ︙ | |||
307 308 309 310 311 312 313 | } } /* * Clean up any synchronization objects in the thread local storage. */ | > > > | > | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
}
}
/*
* Clean up any synchronization objects in the thread local storage.
*/
#ifdef __CYGWIN__
CloseHandle(tsdPtr->event);
#else /* __CYGWIN__ */
Tcl_ConditionFinalize(&(tsdPtr->waitCV));
#endif /* __CYGWIN__ */
Tcl_MutexUnlock(¬ifierMutex);
#endif /* TCL_THREADS */
}
}
/*
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
return;
} else {
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = clientData;
Tcl_MutexLock(¬ifierMutex);
tsdPtr->eventReady = 1;
Tcl_ConditionNotify(&tsdPtr->waitCV);
Tcl_MutexUnlock(¬ifierMutex);
#endif /* TCL_THREADS */
}
}
/*
*----------------------------------------------------------------------
| > > > > | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 |
return;
} else {
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = clientData;
Tcl_MutexLock(¬ifierMutex);
tsdPtr->eventReady = 1;
# ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
# else
Tcl_ConditionNotify(&tsdPtr->waitCV);
# endif /* __CYGWIN__ */
Tcl_MutexUnlock(¬ifierMutex);
#endif /* TCL_THREADS */
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 659 660 661 662 663 664 665 |
filePtr->proc(filePtr->clientData, mask);
}
break;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* 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
| > > > > > > > > > > > > > > > > > > > > > > > > > | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
filePtr->proc(filePtr->clientData, mask);
}
break;
}
return 1;
}
#if defined(TCL_THREADS) && defined(__CYGWIN__)
static DWORD __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
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
#ifdef TCL_THREADS
int waitForFiles;
#else
/*
* 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.
*/
| > > > | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
#ifdef TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else
/*
* 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.
*/
|
| ︙ | ︙ | |||
703 704 705 706 707 708 709 |
* 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
| | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
* 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
/*
* Place this thread on the list of interested threads, signal the
* notifier thread, and wait for a response or a timeout.
*/
#ifdef __CYGWIN__
if (!tsdPtr->hwnd) {
WNDCLASS class;
class.style = 0;
class.cbClsExtra = 0;
class.cbWndExtra = 0;
class.hInstance = TclWinGetTclInstance();
class.hbrBackground = NULL;
class.lpszMenuName = NULL;
class.lpszClassName = L"TclNotifier";
class.lpfnWndProc = NotifierProc;
class.hIcon = NULL;
class.hCursor = NULL;
RegisterClassW(&class);
tsdPtr->hwnd = CreateWindowExW(NULL, class.lpszClassName,
class.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
TclWinGetTclInstance(), NULL);
tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
0 /* !signaled */, NULL);
}
#endif /* __CYGWIN */
Tcl_MutexLock(¬ifierMutex);
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
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
waitForFiles = (tsdPtr->numFdBits > 0);
tsdPtr->pollState = 0;
}
if (waitForFiles) {
/*
* Add the ThreadSpecificData structure of this thread to the list
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
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)) {
DWORD timeout;
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
} else {
timeout = 0xFFFFFFFF;
}
Tcl_MutexUnlock(¬ifierMutex);
MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279);
Tcl_MutexLock(¬ifierMutex);
}
#else
Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr);
#endif /* __CYGWIN__ */
}
tsdPtr->eventReady = 0;
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
DWORD result = GetMessageW(&msg, NULL, 0, 0);
if (result == 0) {
PostQuitMessage(msg.wParam);
/* What to do here? */
} else if (result != (DWORD) -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
tsdPtr->readyMasks = tsdPtr->checkMasks;
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 |
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
tsdPtr->pollState = 0;
}
Tcl_ConditionNotify(&tsdPtr->waitCV);
}
}
Tcl_MutexUnlock(¬ifierMutex);
/*
* Consume the next byte from the notifier pipe if the pipe was
* readable. Note that there may be multiple bytes pending, but to
| > > > > | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 |
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
Tcl_ConditionNotify(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */
}
}
Tcl_MutexUnlock(¬ifierMutex);
/*
* Consume the next byte from the notifier pipe if the pipe was
* readable. Note that there may be multiple bytes pending, but to
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
Tcl_ConditionNotify(¬ifierCV);
Tcl_MutexUnlock(¬ifierMutex);
TclpThreadExit(0);
}
#endif /* TCL_THREADS */
| | | 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
Tcl_ConditionNotify(¬ifierCV);
Tcl_MutexUnlock(¬ifierMutex);
TclpThreadExit(0);
}
#endif /* TCL_THREADS */
#endif /* !HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
*----------------------------------------------------------------------
*/
TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
| < < < < | < < < < < < < < < > > | < | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
*----------------------------------------------------------------------
*/
TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
int fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, NULL);
if (fd == -1) {
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
if (contents != NULL) {
Tcl_DString dstring;
char *native;
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
}
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileName(void)
{
| < | < < < | < < < < < | > > < | < | | | | | | < | | < | | | > | < < | > > | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileName(void)
{
Tcl_Obj *nameObj = Tcl_NewObj();
int fd;
Tcl_IncrRefCount(nameObj);
fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, nameObj);
if (fd == -1) {
Tcl_DecrRefCount(nameObj);
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
TclpObjDeleteFile(nameObj);
close(fd);
return nameObj;
}
/*
*----------------------------------------------------------------------------
*
* TclpTempFileNameForLibrary --
*
* Constructs a file name in the native file system where a dynamically
* loaded library may be placed.
*
* Results:
* Returns the constructed file name. If an error occurs, returns NULL
* and leaves an error message in the interpreter result.
*
* On Unix, it works to load a shared object from a file of any name, so this
* function is merely a thin wrapper around TclpTempFileName().
*
*----------------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileNameForLibrary(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *path) /* Path name of the library in the VFS. */
{
Tcl_Obj *retval = TclpTempFileName();
if (retval == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create temporary file: %s",
Tcl_PosixError(interp)));
}
return retval;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
438 439 440 441 442 443 444 |
/*
* Create a pipe that the child can use to return error information if
* anything goes wrong.
*/
if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
| | | | | > | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
/*
* Create a pipe that the child can use to return error information if
* anything goes wrong.
*/
if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create pipe: %s", Tcl_PosixError(interp)));
goto error;
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
dsArray = TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = 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]);
}
#ifdef USE_VFORK
/*
* After vfork(), do not call code in the child that changes global state,
* because it is using the parent's memory space at that point and writes
* might corrupt the parent: so ensure standard channels are initialized
* in the parent, otherwise SetupStdFile() might initialize them in the
* child.
*/
if (!inputFile) {
Tcl_GetStdChannel(TCL_STDIN);
}
if (!outputFile) {
Tcl_GetStdChannel(TCL_STDOUT);
|
| ︙ | ︙ | |||
491 492 493 494 495 496 497 |
if (!SetupStdFile(inputFile, TCL_STDIN)
|| !SetupStdFile(outputFile, TCL_STDOUT)
|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
|| (joinThisError &&
((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf(errSpace,
| | | | | | | > > | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
if (!SetupStdFile(inputFile, TCL_STDIN)
|| !SetupStdFile(outputFile, TCL_STDOUT)
|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
|| (joinThisError &&
((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf(errSpace,
"%dforked process couldn't set up input/output", errno);
len = strlen(errSpace);
if (len != (size_t) write(fd, errSpace, len)) {
Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut");
}
_exit(1);
}
/*
* Close the input side of the error pipe.
*/
RestoreSignals();
execvp(newArgv[0], newArgv); /* INTL: Native. */
sprintf(errSpace, "%dcouldn't execute \"%.150s\"", errno, argv[0]);
len = strlen(errSpace);
if (len != (size_t) write(fd, errSpace, len)) {
Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut");
}
_exit(1);
}
/*
* Free the mem we used for the fork
*/
for (i = 0; i < argc; i++) {
Tcl_DStringFree(&dsArray[i]);
}
TclStackFree(interp, newArgv);
TclStackFree(interp, dsArray);
if (pid == -1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't fork child process: %s", Tcl_PosixError(interp)));
goto error;
}
/*
* Read back from the error pipe to see if the child started up OK. The
* info in the pipe (if any) consists of a decimal errno value followed by
* an error message.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(errPipeIn);
count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
if (count > 0) {
char *end;
errSpace[count] = 0;
errno = strtol(errSpace, &end, 10);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s",
end, Tcl_PosixError(interp)));
goto error;
}
TclpCloseFile(errPipeIn);
*pidPtr = (Tcl_Pid) INT2PTR(pid);
return TCL_OK;
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
int flags) /* Reserved for future use. */
{
int fileNums[2];
if (pipe(fileNums) < 0) {
| | | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 |
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
int flags) /* Reserved for future use. */
{
int fileNums[2];
if (pipe(fileNums) < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
fcntl(fileNums[0], F_SETFD, FD_CLOEXEC);
fcntl(fileNums[1], F_SETFD, FD_CLOEXEC);
*rchan = Tcl_MakeFileChannel(INT2PTR(fileNums[0]), TCL_READABLE);
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 877 |
void
TclGetAndDetachPids(
Tcl_Interp *interp, /* Interpreter to append the PIDs to. */
Tcl_Channel chan) /* Handle for the pipeline. */
{
PipeState *pipePtr;
const Tcl_ChannelType *chanTypePtr;
int i;
| > < | > > | < | > | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
void
TclGetAndDetachPids(
Tcl_Interp *interp, /* Interpreter to append the PIDs to. */
Tcl_Channel chan) /* Handle for the pipeline. */
{
PipeState *pipePtr;
const Tcl_ChannelType *chanTypePtr;
Tcl_Obj *pidsObj;
int i;
/*
* Punt if the channel is not a command channel.
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewIntObj(
PTR2INT(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/*
|
| ︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
int i;
| | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
int i;
Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
|
| ︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 | return TCL_OK; } /* * Extract the process IDs from the pipe structure. */ | | < | > | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 |
return TCL_OK;
}
/*
* Extract the process IDs from the pipe structure.
*/
pipePtr = 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_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
|
| ︙ | ︙ |
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
DLLIMPORT extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
const char *, int, const char *, const char *);
DLLIMPORT extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
DLLIMPORT extern __stdcall void OutputDebugStringW(const WCHAR *);
DLLIMPORT extern __stdcall int IsDebuggerPresent();
| | > < < < < | < | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
DLLIMPORT extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
const char *, int, const char *, const char *);
DLLIMPORT extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
DLLIMPORT extern __stdcall void OutputDebugStringW(const WCHAR *);
DLLIMPORT extern __stdcall int IsDebuggerPresent();
DLLIMPORT extern int cygwin_conv_path(int, const void *, void *, int);
DLLIMPORT extern int cygwin_conv_path_list(int, const void *, void *, int);
# define USE_PUTENV 1
# define USE_PUTENV_FOR_UNSET 1
/* On Cygwin, the environment is imported from the Cygwin DLL. */
# define environ __cygwin_environ
# define timezone _timezone
DLLIMPORT extern char **__cygwin_environ;
MODULE_SCOPE int TclOSstat(const char *name, Tcl_StatBuf *statBuf);
MODULE_SCOPE int TclOSlstat(const char *name, Tcl_StatBuf *statBuf);
#elif defined(HAVE_STRUCT_STAT64)
# define TclOSstat stat64
# define TclOSlstat lstat64
#else
# define TclOSstat stat
# define TclOSlstat lstat
#endif
/*
*---------------------------------------------------------------------------
* Miscellaneous includes that might be missing.
*---------------------------------------------------------------------------
*/
#include <sys/file.h>
#ifdef HAVE_SYS_SELECT_H
# include <sys/select.h>
#endif
#include <sys/stat.h>
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
#if HAVE_SYS_TIME_H
# include <sys/time.h>
#else
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 | #else # ifdef HAVE_BSDGETTIMEOFDAY # define gettimeofday BSDgettimeofday # endif #endif #ifdef GETTOD_NOT_DECLARED | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 | #else # ifdef HAVE_BSDGETTIMEOFDAY # define gettimeofday BSDgettimeofday # endif #endif #ifdef GETTOD_NOT_DECLARED extern int gettimeofday(struct timeval *tp, struct timezone *tzp); #endif /* *--------------------------------------------------------------------------- * Define access mode constants if they aren't already defined. *--------------------------------------------------------------------------- |
| ︙ | ︙ | |||
742 743 744 745 746 747 748 | 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); | | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 | 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); MODULE_SCOPE void *TclpMakeTcpClientChannelMode( void *tcpSocket, int mode); #endif /* _TCLUNIXPORT */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixSock.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | * once, and so can be used without regard to side effects. */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) /* "sock" + a pointer in hex + \0 */ | | | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
* once, and so can be used without regard to side effects.
*/
#define SET_BITS(var, bits) ((var) |= (bits))
#define CLEAR_BITS(var, bits) ((var) &= ~(bits))
/* "sock" + a pointer in hex + \0 */
#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1)
#define SOCK_TEMPLATE "sock%lx"
#undef SOCKET /* Possible conflict with win32 SOCKET */
/*
* This is needed to comply with the strict aliasing rules of GCC, but it also
* simplifies casting between the different sockaddr types.
*/
typedef union {
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
Tcl_Channel channel; /* Channel associated with this file. */
TcpFdList fds; /* The file descriptors of the sockets. */
int flags; /* ORed combination of the bitfields defined
* below. */
/*
* Only needed for server sockets
*/
| > | > | > > | | | | | | | | < < | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 |
Tcl_Channel channel; /* Channel associated with this file. */
TcpFdList fds; /* The file descriptors of the sockets. */
int flags; /* ORed combination of the bitfields defined
* below. */
/*
* Only needed for server sockets
*/
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
ClientData acceptProcData; /* The data for the accept proc. */
/*
* Only needed for client sockets
*/
struct addrinfo *addrlist; /* Addresses to connect to. */
struct addrinfo *addr; /* Iterator over addrlist. */
struct addrinfo *myaddrlist;/* Local address. */
struct addrinfo *myaddr; /* Iterator over myaddrlist. */
int filehandlers; /* Caches FileHandlers that get set up while
* an async socket is not yet connected. */
int status; /* Cache status of async socket. */
int cachedBlocking; /* Cache blocking mode of async socket. */
};
/*
* These bits may be ORed together into the "flags" field of a TcpState
* structure.
*/
#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */
#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */
/*
* 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
* connection request will fail.
*/
#ifndef SOMAXCONN
# define SOMAXCONN 100
#elif (SOMAXCONN < 100)
# undef SOMAXCONN
# define SOMAXCONN 100
#endif /* SOMAXCONN < 100 */
/*
* The following defines how much buffer space the kernel should maintain for
* a socket.
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
} else {
native = u.nodename;
}
}
if (native == NULL) {
native = tclEmptyStringRep;
}
| | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
} else {
native = u.nodename;
}
}
if (native == NULL) {
native = tclEmptyStringRep;
}
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
*
* There is no portable macro for the maximum length of host names
* returned by gethostbyname(). We should only trust SYS_NMLN if it is at
* least 255 + 1 bytes to comply with DNS host name limits.
*
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
# else
char buffer[256];
# endif
if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */
native = buffer;
}
| | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
# else
char buffer[256];
# endif
if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
*lengthPtr = strlen(native);
*valuePtr = ckalloc((*lengthPtr) + 1);
memcpy(*valuePtr, native, (size_t)(*lengthPtr)+1);
}
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
static int
TcpBlockModeProc(
ClientData instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
| | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
static int
TcpBlockModeProc(
ClientData instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = instanceData;
if (mode == TCL_MODE_BLOCKING) {
CLEAR_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
} else {
SET_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
}
if (statePtr->flags & TCP_ASYNC_CONNECT) {
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
TcpInputProc(
ClientData instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
| | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
TcpInputProc(
ClientData instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = instanceData;
int bytesRead;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0);
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
static int
TcpOutputProc(
ClientData instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
| | | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
static int
TcpOutputProc(
ClientData instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = instanceData;
int written;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
/* ARGSUSED */
static int
TcpCloseProc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp) /* For error reporting - unused. */
{
| | | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 |
/* ARGSUSED */
static int
TcpCloseProc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp) /* For error reporting - unused. */
{
TcpState *statePtr = instanceData;
int errorCode = 0;
TcpFdList *fds;
/*
* Delete a file handler that may be active for this socket if this is a
* server socket - the file handler was created automatically by Tcl as
* part of the mechanism to accept new client connections. Channel
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 |
static int
TcpClose2Proc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 |
static int
TcpClose2Proc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = instanceData;
int errorCode = 0;
int sd;
/*
* Shutdown the OS socket handle.
*/
switch(flags) {
case TCL_CLOSE_READ:
sd = SHUT_RD;
break;
case TCL_CLOSE_WRITE:
sd = SHUT_WR;
break;
default:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"socket close2proc called bidirectionally", -1));
}
return TCL_ERROR;
}
if (shutdown(statePtr->fds.fd,sd) < 0) {
errorCode = errno;
}
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* TcpHostPortList --
*
* This function is called by the -gethostname and -getpeername
* switches of TcpGetOptionProc() to add three list elements
* with the textual representation of the given address to the
* given DString.
*
* Results:
* None.
*
* Side effects:
* Adds three elements do dsPtr
*
*----------------------------------------------------------------------
*/
static void
TcpHostPortList(
Tcl_Interp *interp,
Tcl_DString *dsPtr,
address addr,
socklen_t salen)
{
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV];
int flags = 0;
getnameinfo(&addr.sa, salen,
nhost, sizeof(nhost), nport, sizeof(nport),
NI_NUMERICHOST | NI_NUMERICSERV);
Tcl_DStringAppendElement(dsPtr, nhost);
/*
* We don't want to resolve INADDR_ANY and sin6addr_any; they
* can sometimes cause problems (and never have a name).
*/
if (addr.sa.sa_family == AF_INET) {
if (addr.sa4.sin_addr.s_addr == INADDR_ANY) {
flags |= NI_NUMERICHOST;
}
#ifndef NEED_FAKE_RFC2553
} else if (addr.sa.sa_family == AF_INET6) {
if ((IN6_ARE_ADDR_EQUAL(&addr.sa6.sin6_addr,
&in6addr_any))
|| (IN6_IS_ADDR_V4MAPPED(&addr.sa6.sin6_addr) &&
addr.sa6.sin6_addr.s6_addr[12] == 0 &&
addr.sa6.sin6_addr.s6_addr[13] == 0 &&
addr.sa6.sin6_addr.s6_addr[14] == 0 &&
addr.sa6.sin6_addr.s6_addr[15] == 0)) {
flags |= NI_NUMERICHOST;
}
#endif /* NEED_FAKE_RFC2553 */
}
/* Check if reverse DNS has been switched off globally */
if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
flags |= NI_NUMERICHOST;
}
if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0, flags) == 0) {
/* Reverse mapping worked */
Tcl_DStringAppendElement(dsPtr, host);
} else {
/* Reverse mappong failed - use the numeric rep once more */
Tcl_DStringAppendElement(dsPtr, nhost);
}
Tcl_DStringAppendElement(dsPtr, nport);
}
/*
*----------------------------------------------------------------------
*
* TcpGetOptionProc --
*
* Computes an option value for a TCP socket based channel, or a list of
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
| | < < < | < < < < < | | | < < < < < < < > | | < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 |
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
TcpState *statePtr = instanceData;
size_t len = 0;
if (optionName != NULL) {
len = strlen(optionName);
}
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
socklen_t optlen = sizeof(int);
int err, ret;
if (statePtr->status == 0) {
ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
(char *) &err, &optlen);
if (ret < 0) {
err = errno;
}
} else {
err = statePtr->status;
statePtr->status = 0;
}
if (err != 0) {
Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1);
}
return TCL_OK;
}
if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
(strncmp(optionName, "-peername", len) == 0))) {
address peername;
socklen_t size = sizeof(peername);
if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
}
TcpHostPortList(interp, dsPtr, peername, size);
if (len) {
return TCL_OK;
}
Tcl_DStringEndSublist(dsPtr);
} else {
/*
* getpeername failed - but if we were asked for all the options
* (len==0), don't flag an error at that point because it could be
* an fconfigure request on a server socket (which have no peer).
* Same must be done on win&mac.
*/
if (len) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get peername: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
}
if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
(strncmp(optionName, "-sockname", len) == 0))) {
TcpFdList *fds;
address sockname;
socklen_t size;
int found = 0;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sockname");
Tcl_DStringStartSublist(dsPtr);
}
for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
size = sizeof(sockname);
if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) {
found = 1;
TcpHostPortList(interp, dsPtr, sockname, size);
}
}
if (found) {
if (len) {
return TCL_OK;
}
Tcl_DStringEndSublist(dsPtr);
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
if (len > 0) {
return Tcl_BadChannelOption(interp, optionName, "peername sockname");
|
| ︙ | ︙ | |||
821 822 823 824 825 826 827 |
static void
TcpWatchProc(
ClientData instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
| | | < | 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 |
static void
TcpWatchProc(
ClientData instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = instanceData;
if (statePtr->acceptProc != NULL) {
/*
* Make sure we don't mess with server sockets since they will never
* be readable or writable at the Tcl level. This keeps Tcl scripts
* from interfering with the -accept behavior (bug #3394732).
*/
return;
}
if (statePtr->flags & TCP_ASYNC_CONNECT) {
/* Async sockets use a FileHandler internally while connecting, so we
* need to cache this request until the connection has succeeded. */
statePtr->filehandlers = mask;
} else if (mask) {
Tcl_CreateFileHandler(statePtr->fds.fd, mask,
(Tcl_FileProc *) Tcl_NotifyChannel, statePtr->channel);
} else {
Tcl_DeleteFileHandler(statePtr->fds.fd);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
/* ARGSUSED */
static int
TcpGetHandleProc(
ClientData instanceData, /* The socket state. */
int direction, /* Not used. */
ClientData *handlePtr) /* Where to store the handle. */
{
| | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
/* ARGSUSED */
static int
TcpGetHandleProc(
ClientData instanceData, /* The socket state. */
int direction, /* Not used. */
ClientData *handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = instanceData;
*handlePtr = INT2PTR(statePtr->fds.fd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
int async = state->flags & TCP_ASYNC_CONNECT;
if (async_callback) {
goto reenter;
}
for (state->addr = state->addrlist; state->addr != NULL;
| | < | > | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 |
int async = state->flags & TCP_ASYNC_CONNECT;
if (async_callback) {
goto reenter;
}
for (state->addr = state->addrlist; state->addr != NULL;
state->addr = state->addr->ai_next) {
status = -1;
for (state->myaddr = state->myaddrlist; state->myaddr != NULL;
state->myaddr = state->myaddr->ai_next) {
int reuseaddr;
/*
* No need to try combinations of local and remote addresses of
* different families.
*/
if (state->myaddr->ai_family != state->addr->ai_family) {
continue;
}
/*
* Close the socket if it is still open from the last unsuccessful
* iteration.
*/
if (state->fds.fd >= 0) {
close(state->fds.fd);
state->fds.fd = -1;
}
state->fds.fd = socket(state->addr->ai_family, SOCK_STREAM, 0);
if (state->fds.fd < 0) {
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
/*
* Set kernel space buffering
*/
TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE);
if (async) {
| | > | | < | > > | > < > > | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
/*
* Set kernel space buffering
*/
TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE);
if (async) {
status = TclUnixSetBlockingMode(state->fds.fd,
TCL_MODE_NONBLOCKING);
if (status < 0) {
continue;
}
}
reuseaddr = 1;
(void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR,
(char *) &reuseaddr, sizeof(reuseaddr));
status = bind(state->fds.fd, state->myaddr->ai_addr,
state->myaddr->ai_addrlen);
if (status < 0) {
continue;
}
/*
* Attempt to connect. The connect may fail at present with an
* EINPROGRESS but at a later time it will complete. The caller
* will set up a file handler on the socket if she is interested
* in being informed when the connect completes.
*/
status = connect(state->fds.fd, state->addr->ai_addr,
state->addr->ai_addrlen);
if (status < 0 && errno == EINPROGRESS) {
Tcl_CreateFileHandler(state->fds.fd,
TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, state);
return TCL_OK;
reenter:
Tcl_DeleteFileHandler(state->fds.fd);
/*
* Read the error state from the socket to see if the async
* connection has succeeded or failed. As this clears the
* error condition, we cache the status in the socket state
* struct for later retrieval by [fconfigure -error].
*/
optlen = sizeof(int);
getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR,
(char *) &status, &optlen);
state->status = status;
}
if (status == 0) {
CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
goto out;
}
}
}
out:
if (async_callback) {
/*
* An asynchonous connection has finally succeeded or failed.
*/
TcpWatchProc(state, state->filehandlers);
TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking);
/*
* We need to forward the writable event that brought us here, bcasue
* upon reading of getsockopt(SO_ERROR), at least some OSes clear the
* writable state from the socket, and so a subsequent select() on
* behalf of a script level [fileevent] would not fire. It doesn't
* hurt that this is also called in the successful case and will save
* the event mechanism one roundtrip through select().
*/
Tcl_NotifyChannel(state->channel, TCL_WRITABLE);
} else if (status != 0) {
/*
* Failure for either a synchronous connection, or an async one that
* failed before it could enter background mode, e.g. because an
* invalid -myaddr was given.
*/
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 |
const char *errorMsg = NULL;
struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
char channelName[SOCK_CHAN_LENGTH];
/*
* Do the name lookups for the local and remote addresses.
*/
| > | | > | < | < < | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
const char *errorMsg = NULL;
struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
char channelName[SOCK_CHAN_LENGTH];
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
|| !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", errorMsg));
}
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
|
| ︙ | ︙ | |||
1141 1142 1143 1144 1145 1146 1147 |
* Create a new client socket and wrap it in a channel.
*/
if (CreateClientSocket(interp, state) != TCL_OK) {
TcpCloseProc(state, NULL);
return NULL;
}
| | | | | 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 |
* Create a new client socket and wrap it in a channel.
*/
if (CreateClientSocket(interp, state) != TCL_OK) {
TcpCloseProc(state, NULL);
return NULL;
}
sprintf(channelName, SOCK_TEMPLATE, (long) state);
state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state,
(TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(interp, state->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_Close(NULL, state->channel);
return NULL;
}
return state->channel;
}
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
ClientData sock) /* The socket to wrap up into a channel. */
{
| | < > | | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
ClientData sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, (TCL_READABLE | TCL_WRITABLE));
}
/*
*----------------------------------------------------------------------
*
* TclpMakeTcpClientChannelMode --
*
* Creates a Tcl_Channel from an existing client TCP socket
* with given mode.
*
* Results:
* The Tcl_Channel wrapped around the preexisting TCP socket.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpMakeTcpClientChannelMode(
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
statePtr = ckalloc(sizeof(TcpState));
|
| ︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 |
const char *errorMsg = NULL;
TcpFdList *fds = NULL, *newfds;
/*
* Try to record and return the most meaningful error message, i.e. the
* one from the first socket that went the farthest before it failed.
*/
| > | > | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
const char *errorMsg = NULL;
TcpFdList *fds = NULL, *newfds;
/*
* Try to record and return the most meaningful error message, i.e. the
* one from the first socket that went the farthest before it failed.
*/
enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP;
int my_errno = 0;
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
my_errno = errno;
goto error;
}
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
addrPtr->ai_protocol);
if (sock == -1) {
if (howfar < SOCKET) {
howfar = SOCKET;
my_errno = errno;
}
continue;
}
|
| ︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 |
/* Missing on: Solaris 2.8 */
if (addrPtr->ai_family == AF_INET6) {
int v6only = 1;
(void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
&v6only, sizeof(v6only));
}
| | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
/* Missing on: Solaris 2.8 */
if (addrPtr->ai_family == AF_INET6) {
int v6only = 1;
(void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
&v6only, sizeof(v6only));
}
#endif /* IPV6_V6ONLY */
status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
if (status == -1) {
if (howfar < BIND) {
howfar = BIND;
my_errno = errno;
}
|
| ︙ | ︙ | |||
1359 1360 1361 1362 1363 1364 1365 |
* Allocate a new TcpState for this socket.
*/
statePtr = ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
| | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
* Allocate a new TcpState for this socket.
*/
statePtr = ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
newfds = &statePtr->fds;
} else {
newfds = ckalloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
|
| ︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 |
}
if (statePtr != NULL) {
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
return statePtr->channel;
}
if (interp != NULL) {
| < | | | > > > | > | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 |
}
if (statePtr != NULL) {
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
return statePtr->channel;
}
if (interp != NULL) {
Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1);
if (errorMsg == NULL) {
errno = my_errno;
Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1);
} else {
Tcl_AppendToObj(errorObj, errorMsg, -1);
}
Tcl_SetObjResult(interp, errorObj);
}
if (sock != -1) {
close(sock);
}
return NULL;
}
|
| ︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 |
TcpState *newSockState; /* State for new socket. */
address addr; /* The remote address */
socklen_t len; /* For accept interface */
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
len = sizeof(addr);
| | | | | 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 |
TcpState *newSockState; /* State for new socket. */
address addr; /* The remote address */
socklen_t len; /* For accept interface */
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
len = sizeof(addr);
newsock = accept(fds->fd, &addr.sa, &len);
if (newsock < 0) {
return;
}
/*
* Set close-on-exec flag to prevent the newly accepted socket from being
* inherited by child processes.
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = ckalloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
sprintf(channelName, SOCK_TEMPLATE, (long) newSockState);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, (TCL_READABLE | TCL_WRITABLE));
Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
"auto crlf");
if (fds->statePtr->acceptProc != NULL) {
getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
fds->statePtr->acceptProc(fds->statePtr->acceptProcData,
newSockState->channel, host, atoi(port));
}
}
/*
|
| ︙ | ︙ |
Changes to unix/tclXtNotify.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include <X11/Intrinsic.h> #include "tclInt.h" | < < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include <X11/Intrinsic.h>
#include "tclInt.h"
/*
* This structure is used to keep track of the notifier info for a a
* registered file.
*/
typedef struct FileHandler {
int fd;
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | static void FileProc(ClientData clientData, int *source, XtInputId *id); static void NotifierExitHandler(ClientData clientData); static void TimerProc(ClientData clientData, XtIntervalId *id); static void CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); static void DeleteFileHandler(int fd); | | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | static void FileProc(ClientData clientData, int *source, XtInputId *id); static void NotifierExitHandler(ClientData clientData); static void TimerProc(ClientData clientData, XtIntervalId *id); static void CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); static void DeleteFileHandler(int fd); static void SetTimer(const Tcl_Time * timePtr); static int WaitForEvent(const Tcl_Time * timePtr); /* * Functions defined in this file for use by users of the Xt Notifier: */ MODULE_SCOPE void InitNotifier(void); MODULE_SCOPE XtAppContext TclSetAppContext(XtAppContext ctx); |
| ︙ | ︙ | |||
261 262 263 264 265 266 267 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ static void SetTimer( | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
* Replaces any previous timer.
*
*----------------------------------------------------------------------
*/
static void
SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
long timeout;
if (!initialized) {
InitNotifier();
}
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 | * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ static int WaitForEvent( | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
* Queues file events that are detected by the select.
*
*----------------------------------------------------------------------
*/
static int
WaitForEvent(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
int timeout;
if (!initialized) {
InitNotifier();
}
|
| ︙ | ︙ |
Changes to unix/tclooConfig.sh.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" | | | | 11 12 13 14 15 16 17 18 19 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" TCLOO_VERSION=1.0 |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE # To enable compilation debugging reverse the comment characters on one of the # following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. | > > > > > | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE # To compile without backward compatibility and deprecated code uncomment the # following NO_DEPRECATED_FLAGS = #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the # following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. TOP_DIR = $(shell cd @srcdir@/..; 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 |
| ︙ | ︙ | |||
108 109 110 111 112 113 114 | #GENERIC_DIR_NATIVE = $(GENERIC_DIR) #TOMMATH_DIR_NATIVE = $(TOMMATH_DIR) #WIN_DIR_NATIVE = $(WIN_DIR) #ROOT_DIR_NATIVE = $(ROOT_DIR) # Fully qualify library path so that `make test` # does not depend on the current directory. | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | #GENERIC_DIR_NATIVE = $(GENERIC_DIR) #TOMMATH_DIR_NATIVE = $(TOMMATH_DIR) #WIN_DIR_NATIVE = $(WIN_DIR) #ROOT_DIR_NATIVE = $(ROOT_DIR) # Fully qualify library path so that `make test` # does not depend on the current directory. LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)' | sed 's!\\!/!g') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ EXESUFFIX = @EXESUFFIX@ VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@ DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ |
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
ZLIB_DLL_FILE = zlib1.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
| | < | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
ZLIB_DLL_FILE = zlib1.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is
# available *BEFORE* running make for the first time. Certain build targets
# (make genstubs, make install) need it to be available on the PATH. This
# executable should *NOT* be required just to do a normal build although
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
SHELL = @SHELL@
RM = rm -f
COPY = cp
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} -I"${ZLIB_DIR}" \
-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
| | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
SHELL = @SHELL@
RM = rm -f
COPY = cp
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} -I"${ZLIB_DIR}" \
-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${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"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
| | < < < < < | | < < < < < < | < < < < < < < < < < | < < < < < < < < < < | > > > | > | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 |
TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
tcltest: $(TCLSH) $(TEST_DLL_FILE)
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH)
libraries:
doc:
$(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)
@VC_MANIFEST_EMBED_EXE@
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
$(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE)
# The following targets are configured by autoconf to generate either a shared
# library or static library
${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
@$(RM) ${TCL_STUB_LIB_FILE}
@MAKE_LIB@ ${STUB_OBJS}
@POST_MAKE_LIB@
${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
@VC_MANIFEST_EMBED_DLL@
${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \
$(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
else \
$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
fi;
# Add the object extension to the implicit rules. By default .obj is not
# automatically added.
.SUFFIXES: .${OBJEXT}
.SUFFIXES: .$(RES)
.SUFFIXES: .rc
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 | --no-lines \ $(GENERIC_DIR)/tclGetDate.y # The following target generates the file generic/tclTomMath.h. It needs to be # run (and the results checked) after updating to a new release of libtommath. gentommath_h: | | | | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | --no-lines \ $(GENERIC_DIR)/tclGetDate.y # The following target generates the file generic/tclTomMath.h. It needs to be # run (and the results checked) after updating to a new release of libtommath. gentommath_h: $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \ "$(TOMMATH_DIR_NATIVE)/tommath.h" \ > "$(GENERIC_DIR_NATIVE)/tclTomMath.h" install: all install-binaries install-libraries install-doc install-packages install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ do \ if [ ! -d $$i ] ; then \ |
| ︙ | ︙ | |||
658 659 660 661 662 663 664 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; | | | | | | | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; @echo "Installing package http 2.8.6 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.6.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.5.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; @echo "Installing package platform 1.0.10 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.10.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ |
| ︙ | ︙ | |||
715 716 717 718 719 720 721 | # Specifying TESTFLAGS on the command line is the standard way to pass args to # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages | | | > | | | | > | | | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
# Specifying TESTFLAGS on the command line is the standard way to pass args to
# tcltest, i.e.:
# % make test TESTFLAGS="-verbose bps -file fileName.test"
test: test-tcl test-packages
test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32)
# Useful target to launch a built tclsh with the proper path,...
runtest: binaries $(TCLSH) $(TEST_DLL_FILE)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \
package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \
package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" $(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)
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
| | | | | | | | | | | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 |
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
$(RM) $(TCLSH) $(CAT32)
$(RM) *.pch *.ilk *.pdb
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
tcl.hpj config.status.lineno
#
# Bundled package targets
#
PKG_CFG_ARGS = @PKG_CFG_ARGS@
PKG_DIR = ./pkgs
packages:
@builddir=`pwd -P`; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
if [ -x $$i/configure ] ; then \
pkg=`basename $$i`; \
mkdir -p $(PKG_DIR)/$$pkg; \
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; \
echo "Configuring package '$$i' wd = `pwd -P`"; \
$$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \
fi ; \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \
fi; \
fi; \
done; \
cd $$builddir
install-packages: packages
@builddir=`pwd -P`; \
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)"; ) \
fi; \
fi; \
done; \
cd $$builddir
test-packages: tcltest packages
@builddir=`pwd -P`; \
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=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \
fi; \
fi; \
done; \
cd $$builddir
clean-packages:
@builddir=`pwd -P`; \
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; ) \
fi; \
fi; \
done; \
cd $$builddir
distclean-packages:
@builddir=`pwd -P`; \
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; ) \
fi; \
cd $$builddir; \
|
| ︙ | ︙ |
Changes to win/README.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | and Visual C++ 6 or newer or | | | | | | | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | and Visual C++ 6 or newer or Linux + MinGW-w64 [http://mingw-w64.sourceforge.net/] (win32 or win64) or Cygwin + MinGW-w64 [http://cygwin.com/install.html] (win32 or win64) or Darwin + MinGW-w64 [http://mingw-w64.sourceforge.net/] (win32 or win64) or Msys + MinGW-w64 [http://mingw-w64.sourceforge.net/] (win32 or win64) or Msys + MinGW [http://www.mingw.org/download.shtml] (win32 only) In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. If you are building with Visual C++, in the "win" subdirectory of the source release, you will find "makefile.vc". This is the makefile for the |
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | If you are building with Linux, Cygwin or Msys, you can use the configure script that lives in the win subdirectory. The Linux/Cygwin/Msys based configure/build process works just like the UNIX one, so you will want to refer to ../unix/README for available configure options. If you want 64-bit executables (x86_64), you need to configure using | | | | | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | If you are building with Linux, Cygwin or Msys, you can use the configure script that lives in the win subdirectory. The Linux/Cygwin/Msys based configure/build process works just like the UNIX one, so you will want to refer to ../unix/README for available configure options. If you want 64-bit executables (x86_64), you need to configure using the --enable-64bit option. Make sure that the x86_64-w64-mingw32 compiler is present. For Cygwin this compiler can be found in the "mingw64-x86_64-gcc-core" package, which can be installed through the normal Cygwin install process. If you only want 32-bit executables, the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin and Msys, you can download a suitable win32 or win64 compiler from [https://sourceforge.net/projects/mingw-w64/files/] 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 tclsh85.exe, you must ensure that tcl85.dll is on your path, in the system directory, or in the directory containing tclsh86.exe. Note: Tcl no longer provides support for Win32s. 3. Test suite ------------- |
| ︙ | ︙ |
Changes to win/buildall.vc.bat.
1 2 3 4 5 6 7 8 | @echo off :: This is an example batchfile for building everything. Please :: edit this (or make your own) for your needs and wants using :: the instructions for calling makefile.vc found in makefile.vc set SYMBOLS= :OPTIONS | > | 1 2 3 4 5 6 7 8 9 | @echo off :: This is an example batchfile for building everything. Please :: edit this (or make your own) for your needs and wants using :: the instructions for calling makefile.vc found in makefile.vc set SYMBOLS= :OPTIONS |
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | :: reset errorlevel cd > nul :: You might have installed your developer studio to add itself to the :: path or have already run vcvars32.bat. Testing these envars proves :: cl.exe and friends are in your path. :: | | | | | > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | :: reset errorlevel cd > nul :: You might have installed your developer studio to add itself to the :: path or have already run vcvars32.bat. Testing these envars proves :: cl.exe and friends are in your path. :: if defined VCINSTALLDIR (goto :startBuilding) if defined MSDEVDIR (goto :startBuilding) if defined MSVCDIR (goto :startBuilding) if defined MSSDK (goto :startBuilding) if defined WINDOWSSDKDIR (goto :startBuilding) :: We need to run the development environment batch script that comes :: with developer studio (v4,5,6,7,etc...) All have it. This path :: 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" |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | :: Build the normal stuff along with the help file. :: set OPTS=none if not %SYMBOLS%.==. set OPTS=symbols nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 if errorlevel 1 goto error | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | :: Build the normal stuff along with the help file. :: set OPTS=none if not %SYMBOLS%.==. set OPTS=symbols nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 if errorlevel 1 goto error :: Build the static core and shell. :: set OPTS=static,msvcrt if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 if errorlevel 1 goto error set OPTS= set SYMBOLS= goto end :error |
| ︙ | ︙ |
Changes to win/coffbase.txt.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | itcl 0x10500000 0x00080000 itk 0x10580000 0x00080000 bltlite 0x10600000 0x00080000 blt 0x10680000 0x00080000 iocpsock 0x10700000 0x00080000 tls 0x10780000 0x00100000 winico 0x10880000 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 ; ; insert new packages here ; snack 0x1E000000 0x00400000 sound 0x1E400000 0x00400000 snackogg 0x1E800000 0x00200000 | > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | 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 ; ; insert new packages here ; snack 0x1E000000 0x00400000 sound 0x1E400000 0x00400000 snackogg 0x1E800000 0x00200000 |
Changes to win/configure.
| ︙ | ︙ | |||
836 837 838 839 840 841 842 | if test -n "$ac_init_help"; then cat <<\_ACEOF Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] | | | | | | 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 |
if test -n "$ac_init_help"; then
cat <<\_ACEOF
Optional Features:
--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-64bit enable 64bit support (where applicable)
--enable-wince enable Win/CE support (where applicable)
--enable-symbols build with debugging symbols (default: off)
--enable-embedded-manifest
embed manifest if possible (default: yes)
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>
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 | # 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_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 | | | 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 | # 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_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 TCL_PATCH_LEVEL=".0" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ | |||
3064 3065 3066 3067 3068 3069 3070 |
enableval="$enable_threads"
tcl_ok=$enableval
else
tcl_ok=yes
fi;
if test "$tcl_ok" = "yes"; then
| | | | 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 |
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
|
| ︙ | ︙ | |||
3594 3595 3596 3597 3598 3599 3600 |
RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \$@"
POST_MAKE_LIB="\${RANLIB} \$@"
MAKE_EXE="\${CC} -o \$@"
LIBPREFIX="lib"
| < > | 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 |
RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \$@"
POST_MAKE_LIB="\${RANLIB} \$@"
MAKE_EXE="\${CC} -o \$@"
LIBPREFIX="lib"
extra_cflags="$extra_cflags -pipe"
extra_ldflags="$extra_ldflags -pipe"
if test "${SHARED_BUILD}" = "0" ; then
# static
echo "$as_me:$LINENO: result: using static flags" >&5
echo "${ECHO_T}using static flags" >&6
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
|
| ︙ | ︙ | |||
4340 4341 4342 4343 4344 4345 4346 | 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 #------------------------------------------------------------------------ | < < < < < < < < < > > > > > > > | > > > | 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 |
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
#------------------------------------------------------------------------
if test "${enable_shared+set}" = "set"; then
enableval="$enable_shared"
tcl_ok=$enableval
else
tcl_ok=yes
fi
if test "$tcl_ok" = "yes"; then
ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
if test "$do64bit" = "yes"; then
ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib
else
ZLIB_LIBS=\${ZLIB_DIR}/win32/zdll.lib
fi
else
ZLIB_OBJS=\${ZLIB_OBJS}
cat >>confdefs.h <<_ACEOF
|
| ︙ | ︙ |
Changes to win/configure.in.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # 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_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # 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_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 TCL_PATCH_LEVEL=".0" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ | |||
116 117 118 119 120 121 122 | 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 #------------------------------------------------------------------------ | < < < < > > > | > | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
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
#------------------------------------------------------------------------
AS_IF([test "${enable_shared+set}" = "set"], [
enableval="$enable_shared"
tcl_ok=$enableval
], [
tcl_ok=yes
])
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
AS_IF([test "$do64bit" = "yes"], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/zdll.lib])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib])
])
], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_DEFINE_UNQUOTED(NO_VIZ, 1)
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
AC_CHECK_TYPE([intptr_t], [
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
tcl_cv_intrinsics=no)
)
if test "$tcl_cv_intrinsics" = "yes"; then
AC_DEFINE(HAVE_INTRIN_H, 1,
[Defined when the compilers supports intrinsics])
fi
| | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
tcl_cv_intrinsics=no)
)
if test "$tcl_cv_intrinsics" = "yes"; then
AC_DEFINE(HAVE_INTRIN_H, 1,
[Defined when the compilers supports intrinsics])
fi
# See if the <wspiapi.h> header file is present
AC_CACHE_CHECK(for wspiapi.h,
tcl_cv_wspiapi_h,
AC_TRY_COMPILE([
#include <wspiapi.h>
], [],
tcl_cv_wspiapi_h=yes,
|
| ︙ | ︙ |
Changes to win/makefile.bc.
| ︙ | ︙ | |||
429 430 431 432 433 434 435 | -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.8" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8" @echo installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" | | | | | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.8" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8" @echo installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" @echo installing msgcat1.5 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" @echo installing tcltest2.3 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" @echo installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" |
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # Copyright (c) 2003-2008 Pat Thoyts. #------------------------------------------------------------------------------ | | | < | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # Copyright (c) 2003-2008 Pat Thoyts. #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or # VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) MSG = ^ You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ Platform SDK first to setup the environment. Jump to this line to read^ the build instructions. !error $(MSG) !endif |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | # help files (.chm) # # 4) Macros usable on the commandline: # INSTALLDIR=<path> # Sets where to install Tcl from the built binaries. # C:\Progra~1\Tcl is assumed when not specified. # | | | | | > > > > > > > > > | > < < < < < < | | < > | | < | > | | > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | # help files (.chm) # # 4) Macros usable on the commandline: # INSTALLDIR=<path> # Sets where to install Tcl from the built binaries. # C:\Progra~1\Tcl is assumed when not specified. # # OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # # loimpact = Adds a flag for how NT treats the heap to keep memory # in use, low. This is said to impact alloc performance. # msvcrt = Affects the static option only to switch it from # using libcmt(d) as the C runtime [by default] to # msvcrt(d). This is useful for static embedding # support. # nothreads= Turns off full multithreading support. # pdbs = Build detached symbols for release builds. # profile = Adds profiling hooks. Map file is assumed. # static = Builds a static library of the core instead of a # dll. The static library will contain the dde and reg # extensions. External applications who want to use # this, need to link with the stub library as well as # the static Tcl library.The shell will be static (and # large), as well. # staticpkg = Affects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. # symbols = Debug build. Links to the debug C runtime, disables # optimizations and creates pdb symbols files. # thrdalloc = Use the thread allocator (shared global free pool) # This is the default on threaded builds. # tclalloc = Use the old non-thread allocator # unchecked= Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # # STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # # compdbg = Enables byte compilation logging. # memdbg = Enables the debugging memory allocator. # # CHECKS=64bit,fullwarn,nodep,none # Sets special macros for checking compatability. # # 64bit = Enable 64bit portability warnings (if available) # fullwarn = Builds with full compiler and link warnings enabled. # Very verbose. # nodep = Turns off compatability macros to ensure the core # isn't being built with deprecated functions. # # MACHINE=(ALPHA|AMD64|IA64|IX86) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default # when not specified. If the CPU environment variable has been # set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR=<path> # OUT_DIR=<path> # Hooks to allow the intermediate and output directories to be # changed. $(OUT_DIR) is assumed to be # $(BINROOT)\(Release|Debug) based on if symbols are requested. # $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default. |
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
!if !exist("makefile.vc")
MSG = ^
You must run this makefile only from the directory it is in.^
Please `cd` to its location first.
!error $(MSG)
!endif
| | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
!if !exist("makefile.vc")
MSG = ^
You must run this makefile only from the directory it is in.^
Please `cd` to its location first.
!error $(MSG)
!endif
PROJECT = tcl
!include "rules.vc"
STUBPREFIX = $(PROJECT)stub
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
DDEDOTVERSION = 1.4
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION) INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif $(TMP_DIR)\tclsh.res TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ | > > > > | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION) INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ !if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif !endif $(TMP_DIR)\tclsh.res TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ !if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ |
| ︙ | ︙ | |||
425 426 427 428 429 430 431 | $(TMP_DIR)\tclWinLoad.obj \ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ | | > > > < | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | $(TMP_DIR)\tclWinLoad.obj \ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ !if $(STATIC_BUILD) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !else $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj |
| ︙ | ︙ | |||
561 562 563 564 565 566 567 | dlls: setup $(TCLREGLIB) $(TCLDDELIB) all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs install-pkgs test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) | | | | | | | | | | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | dlls: setup $(TCLREGLIB) $(TCLDDELIB) all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs install-pkgs test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.0 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.0 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif runtest: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLSH) $(SCRIPT) setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) !if !$(STATIC_BUILD) |
| ︙ | ︙ | |||
816 817 818 819 820 821 822 |
!endif
!if exist("$(HELPFILE)")
@echo Installing Windows help
@$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\"
@$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"
!endif
| < | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
!endif
!if exist("$(HELPFILE)")
@echo Installing Windows help
@$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\"
@$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"
!endif
#---------------------------------------------------------------------
# Build tclConfig.sh for the TEA build system.
#---------------------------------------------------------------------
tclConfig: $(OUT_DIR)\tclConfig.sh
$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 | @$(CPY) "$(ROOT)\library\encoding\*.enc" \ "$(SCRIPT_INSTALL_DIR)\encoding\" #" emacs fix install-tzdata: @echo Installing time zone data | | | | | | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 | @$(CPY) "$(ROOT)\library\encoding\*.enc" \ "$(SCRIPT_INSTALL_DIR)\encoding\" #" emacs fix install-tzdata: @echo Installing time zone data @set TCL_LIBRARY=$(ROOT:\=/)/library @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo Installing message catalogs @set TCL_LIBRARY=$(ROOT:\=/)/library @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- # Clean up #--------------------------------------------------------------------- tidy: !if "$(TCLLIB)" != "$(TCLIMPLIB)" |
| ︙ | ︙ |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") #include <stdio.h> #include <math.h> /* * This library is required for x64 builds with _some_ versions of MSVC */ #if defined(_M_IA64) || defined(_M_AMD64) | > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> #define NO_SHLWAPI_GDI #define NO_SHLWAPI_STREAM #define NO_SHLWAPI_REG #include <shlwapi.h> #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") #pragma comment (lib, "shlwapi.lib") #include <stdio.h> #include <math.h> /* * This library is required for x64 builds with _some_ versions of MSVC */ #if defined(_M_IA64) || defined(_M_AMD64) |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | #define snprintf _snprintf #endif /* protos */ | | | | | > | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
#define snprintf _snprintf
#endif
/* protos */
static int CheckForCompilerFeature(const char *option);
static int CheckForLinkerFeature(const char *option);
static int IsIn(const char *string, const char *substring);
static int SubstituteFile(const char *substs, const char *filename);
static int QualifyPath(const char *path);
static const char *GetVersionFromFile(const char *filename, const char *match, int numdots);
static DWORD WINAPI ReadFromPipe(LPVOID args);
/* globals */
#define CHUNK 25
#define STATICBUFFERSIZE 1000
typedef struct {
HANDLE pipe;
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 | "Extract a version from a file:\n" "eg: pkgIndex.tcl \"package ifneeded http\"", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 0; } | | > > > > > > > > > > > | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 |
"Extract a version from a file:\n"
"eg: pkgIndex.tcl \"package ifneeded http\"",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 0;
}
printf("%s\n", GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0'));
return 0;
case 'Q':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -Q path\n"
"Emit the fully qualified path\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return QualifyPath(argv[2]);
}
}
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c|-f|-l|-Q|-s|-V ...\n"
"This is a little helper app to equalize shell differences between WinNT and\n"
"Win9x and get nmake.exe to accomplish its job.\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
static int
CheckForCompilerFeature(
const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
SECURITY_ATTRIBUTES sa;
DWORD threadID;
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
|| strstr(Err.buffer, "D4002") != NULL
|| strstr(Out.buffer, "D9002") != NULL
|| strstr(Err.buffer, "D9002") != NULL
|| strstr(Out.buffer, "D2021") != NULL
|| strstr(Err.buffer, "D2021") != NULL);
}
| | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
|| strstr(Err.buffer, "D4002") != NULL
|| strstr(Out.buffer, "D9002") != NULL
|| strstr(Err.buffer, "D9002") != NULL
|| strstr(Out.buffer, "D2021") != NULL
|| strstr(Err.buffer, "D2021") != NULL);
}
static int
CheckForLinkerFeature(
const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
SECURITY_ATTRIBUTES sa;
DWORD threadID;
|
| ︙ | ︙ | |||
369 370 371 372 373 374 375 | DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 |
return !(strstr(Out.buffer, "LNK1117") != NULL ||
strstr(Err.buffer, "LNK1117") != NULL ||
strstr(Out.buffer, "LNK4044") != NULL ||
strstr(Err.buffer, "LNK4044") != NULL);
}
| | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
return !(strstr(Out.buffer, "LNK1117") != NULL ||
strstr(Err.buffer, "LNK1117") != NULL ||
strstr(Out.buffer, "LNK4044") != NULL ||
strstr(Err.buffer, "LNK4044") != NULL);
}
static DWORD WINAPI
ReadFromPipe(
LPVOID args)
{
pipeinfo *pi = (pipeinfo *) args;
char *lastBuf = pi->buffer;
DWORD dwRead;
BOOL ok;
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
}
lastBuf += dwRead;
goto again;
return 0; /* makes the compiler happy */
}
| | | | > | > | > | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
}
lastBuf += dwRead;
goto again;
return 0; /* makes the compiler happy */
}
static int
IsIn(
const char *string,
const char *substring)
{
return (strstr(string, substring) != NULL);
}
/*
* GetVersionFromFile --
* Looks for a match string in a file and then returns the version
* following the match where a version is anything acceptable to
* package provide or package ifneeded.
*/
static const char *
GetVersionFromFile(
const char *filename,
const char *match,
int numdots)
{
size_t cbBuffer = 100;
static char szBuffer[100];
char *szResult = NULL;
FILE *fp = fopen(filename, "rt");
if (fp != NULL) {
/*
* Read data until we see our match string.
*/
while (fgets(szBuffer, cbBuffer, fp) != NULL) {
LPSTR p, q;
p = strstr(szBuffer, match);
if (p != NULL) {
/*
* Skip to first digit after the match.
*/
p += strlen(match);
while (*p && !isdigit(*p)) {
++p;
}
/*
* Find ending whitespace.
*/
q = p;
while (*q && (strchr("0123456789.ab", *q)) && ((!strchr(".ab", *q)
&& (!strchr("ab", q[-1])) || --numdots))) {
++q;
}
memcpy(szBuffer, p, q - p);
szBuffer[q-p] = 0;
szResult = szBuffer;
break;
|
| ︙ | ︙ | |||
561 562 563 564 565 566 567 | * Usage is something like: * nmakehlp -S << $** > $@ * @PACKAGE_NAME@ $(PACKAGE_NAME) * @PACKAGE_VERSION@ $(PACKAGE_VERSION) * << */ | | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 |
* Usage is something like:
* nmakehlp -S << $** > $@
* @PACKAGE_NAME@ $(PACKAGE_NAME)
* @PACKAGE_VERSION@ $(PACKAGE_VERSION)
* <<
*/
static int
SubstituteFile(
const char *substitutions,
const char *filename)
{
size_t cbBuffer = 1024;
static char szBuffer[1024], szCopy[1024];
char *szResult = NULL;
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 |
int n = 0;
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
}
}
#endif
| | | | > > > > > > > > > > > > > > > > > > > > > > > > | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
int n = 0;
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
}
}
#endif
/*
* Run the substitutions over each line of the input
*/
while (fgets(szBuffer, cbBuffer, fp) != NULL) {
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr) {
char *m = strstr(szBuffer, p->key);
if (m) {
char *cp, *op, *sp;
cp = szCopy;
op = szBuffer;
while (op != m) *cp++ = *op++;
sp = p->value;
while (sp && *sp) *cp++ = *sp++;
op += strlen(p->key);
while (*op) *cp++ = *op++;
*cp = 0;
memcpy(szBuffer, szCopy, sizeof(szCopy));
}
}
printf(szBuffer);
}
list_free(&substPtr);
}
fclose(fp);
return 0;
}
/*
* QualifyPath --
*
* This composes the current working directory with a provided path
* and returns the fully qualified and normalized path.
* Mostly needed to setup paths for testing.
*/
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
char szTmp[MAX_PATH + 1];
char *p;
GetCurrentDirectory(MAX_PATH, szCwd);
while ((p = strchr(szPath, '/')) && *p)
*p = '\\';
PathCombine(szTmp, szCwd, szPath);
PathCanonicalize(szCwd, szTmp);
printf("%s\n", szCwd);
return 0;
}
/*
* Local variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* indent-tabs-mode: t
* tab-width: 8
* End:
*/
|
Changes to win/rules.vc.
1 2 3 4 5 6 7 8 9 10 | #------------------------------------------------------------------------------ # rules.vc -- # # Microsoft Visual C++ makefile include for decoding the commandline # macros. This file does not need editing to build Tcl. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | #------------------------------------------------------------------------------ # rules.vc -- # # Microsoft Visual C++ makefile include for decoding the commandline # macros. This file does not need editing to build Tcl. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 cc32 = $(CC) # built-in default. link32 = link |
| ︙ | ︙ | |||
214 215 216 217 218 219 220 | !if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"] STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 PGO = 0 | | > > > > | > > < | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | !if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"] STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 PGO = 0 MSVCRT = 1 LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 1 UNCHECKED = 0 !else !if [nmakehlp -f $(OPTS) "static"] !message *** Doing static STATIC_BUILD = 1 !else STATIC_BUILD = 0 !endif !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt MSVCRT = 1 !else !if !$(STATIC_BUILD) MSVCRT = 1 !else MSVCRT = 0 !endif !endif !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else TCL_USE_STATIC_PACKAGES = 0 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !else TCL_THREADS = 1 USE_THREAD_ALLOC= 1 !endif !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 !else |
| ︙ | ︙ | |||
283 284 285 286 287 288 289 | LOIMPACT = 0 !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] | | < < < < < < < < < | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | LOIMPACT = 0 !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] !message *** Doing tclalloc USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif !endif #---------------------------------------------------------- # Figure-out how to name our intermediate and output directories. # We wouldn't want different builds to use the same .obj files # by accident. #---------------------------------------------------------- |
| ︙ | ︙ | |||
344 345 346 347 348 349 350 | TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll | < < | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !else TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) EXT = lib !if !$(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif |
| ︙ | ︙ | |||
579 580 581 582 583 584 585 | # Setup tcl version dependent stuff headers #-------------------------------------------------------------- !if "$(PROJECT)" != "tcl" TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) | < < < < < < | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | # Setup tcl version dependent stuff headers #-------------------------------------------------------------- !if "$(PROJECT)" != "tcl" TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) !if $(TCLINSTALL) TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe" !if !exist($(TCLSH)) && $(TCL_THREADS) TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe" !endif TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib" COFFBASE = \must\have\tcl\sources\to\build\this\target TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" !else TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe" !if !exist($(TCLSH)) && $(TCL_THREADS) TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe" !endif TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib" COFFBASE = "$(_TCLDIR)\win\coffbase.txt" TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif !endif |
| ︙ | ︙ |
Changes to win/tcl.m4.
1 2 3 4 5 | #------------------------------------------------------------------------ # SC_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags | < < > | | > > | > > | | > > > > > > > > > | > | > | > > > > > > > | < > | > > > > > > > > > > > > > > > > > > > > > > > < < > > > > > > > > > > > > | < > > | > > | > | > > > > > | > > | > > > > > > > > > > | | | < | | > > | > > | | > > > > > > > > > | > | > | > > > > > > > | < > | > > > > > > > > > > > > > > > > > > > > > > > < < > > > > > > > > > > > > | < > > | > > | > > > > > > > | > > | > > > > > > > > > | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
#------------------------------------------------------------------------
# SC_PATH_TCLCONFIG --
#
# Locate the tclConfig.sh file and perform a sanity check on
# the Tcl compile flags
#
# Arguments:
# none
#
# Results:
#
# Adds the following arguments to configure:
# --with-tcl=...
#
# Defines the following vars:
# TCL_BIN_DIR Full path to the directory containing
# the tclConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TCLCONFIG], [
#
# Ok, lets find the tcl configuration
# First, look for one uninstalled.
# the alternative search directory is invoked by --with-tcl
#
if test x"${no_tcl}" = x ; then
# we reset no_tcl in case something fails here
no_tcl=true
AC_ARG_WITH(tcl,
AC_HELP_STRING([--with-tcl],
[directory containing tcl configuration (tclConfig.sh)]),
with_tclconfig="${withval}")
AC_MSG_CHECKING([for Tcl configuration])
AC_CACHE_VAL(ac_cv_c_tclconfig,[
# First check to see if --with-tcl was specified.
if test x"${with_tclconfig}" != x ; then
case "${with_tclconfig}" in
*/tclConfig.sh )
if test -f "${with_tclconfig}"; then
AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself])
with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`"
fi ;;
esac
if test -f "${with_tclconfig}/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`"
else
AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh])
fi
fi
# then check for a private Tcl installation
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in \
../tcl \
`ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
../../tcl \
`ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
../../../tcl \
`ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/win/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i/win; pwd)`"
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \
`ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \
`ls -d /c/Tcl/lib 2>/dev/null` \
`ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \
`ls -d C:/Tcl/lib 2>/dev/null` \
`ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \
; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i; pwd)`"
break
fi
done
fi
# check in a few other private locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in \
${srcdir}/../tcl \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/win/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i/win; pwd)`"
break
fi
done
fi
])
if test x"${ac_cv_c_tclconfig}" = x ; then
TCL_BIN_DIR="# no Tcl configs found"
AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh])
else
no_tcl=
TCL_BIN_DIR="${ac_cv_c_tclconfig}"
AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh])
fi
fi
])
#------------------------------------------------------------------------
# SC_PATH_TKCONFIG --
#
# Locate the tkConfig.sh file
#
# Arguments:
# none
#
# Results:
#
# Adds the following arguments to configure:
# --with-tk=...
#
# Defines the following vars:
# TK_BIN_DIR Full path to the directory containing
# the tkConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TKCONFIG], [
#
# Ok, lets find the tk configuration
# First, look for one uninstalled.
# the alternative search directory is invoked by --with-tk
#
if test x"${no_tk}" = x ; then
# we reset no_tk in case something fails here
no_tk=true
AC_ARG_WITH(tk,
AC_HELP_STRING([--with-tk],
[directory containing tk configuration (tkConfig.sh)]),
with_tkconfig="${withval}")
AC_MSG_CHECKING([for Tk configuration])
AC_CACHE_VAL(ac_cv_c_tkconfig,[
# First check to see if --with-tkconfig was specified.
if test x"${with_tkconfig}" != x ; then
case "${with_tkconfig}" in
*/tkConfig.sh )
if test -f "${with_tkconfig}"; then
AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself])
with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`"
fi ;;
esac
if test -f "${with_tkconfig}/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`"
else
AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh])
fi
fi
# then check for a private Tk library
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in \
../tk \
`ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \
../../tk \
`ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \
../../../tk \
`ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/win/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i/win; pwd)`"
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \
`ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \
`ls -d /c/Tcl/lib 2>/dev/null` \
`ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \
`ls -d C:/Tcl/lib 2>/dev/null` \
`ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i; pwd)`"
break
fi
done
fi
# check in a few other private locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in \
${srcdir}/../tk \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/win/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i/win; pwd)`"
break
fi
done
fi
])
if test x"${ac_cv_c_tkconfig}" = x ; then
TK_BIN_DIR="# no Tk configs found"
AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh])
else
no_tk=
TK_BIN_DIR="${ac_cv_c_tkconfig}"
AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh])
fi
fi
])
#------------------------------------------------------------------------
# SC_LOAD_TCLCONFIG --
#
# Load the tclConfig.sh file.
#
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
# Sets the following vars:
# SHARED_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
| | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
# Sets the following vars:
# SHARED_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
[ --enable-shared build and link with shared libraries (default: on)],
[tcl_ok=$enableval], [tcl_ok=yes])
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
tcl_ok=$enableval
else
tcl_ok=yes
|
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
#
# Defines the following vars:
# TCL_THREADS
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_THREADS], [
AC_MSG_CHECKING(for building with threads)
| | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
#
# 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
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
# Sets to $(LDFLAGS_OPTIMIZE) if false
# DBGX Debug library extension
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
| | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
# Sets to $(LDFLAGS_OPTIMIZE) if false
# DBGX Debug library extension
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols (default: off)], [tcl_ok=$enableval], [tcl_ok=no])
# 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=""
AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?])
AC_MSG_RESULT([no])
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \[$]@"
POST_MAKE_LIB="\${RANLIB} \[$]@"
MAKE_EXE="\${CC} -o \[$]@"
LIBPREFIX="lib"
| < > | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 |
RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \[$]@"
POST_MAKE_LIB="\${RANLIB} \[$]@"
MAKE_EXE="\${CC} -o \[$]@"
LIBPREFIX="lib"
extra_cflags="$extra_cflags -pipe"
extra_ldflags="$extra_ldflags -pipe"
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 | # # Will define the following vars: # TCL_CFGVAL_ENCODING # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_CFG_ENCODING], [ | | | 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 |
#
# Will define the following vars:
# TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval})
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}")
else
# Default encoding on windows is not "iso8859-1"
AC_DEFINE(TCL_CFGVAL_ENCODING,"cp1252")
fi
|
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
setargv(&argc, &argv);
#endif
/*
* Forward slashes substituted for backslashes.
*/
| | | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
setargv(&argc, &argv);
#endif
/*
* Forward slashes substituted for backslashes.
*/
for (p = argv[0]; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#endif
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
/*
* Precompute an overly pessimistic guess at the number of arguments in
* the command line by counting non-space spans.
*/
size = 2;
| | | | | | | | | | | | | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
/*
* Precompute an overly pessimistic guess at the number of arguments in
* the command line by counting non-space spans.
*/
size = 2;
for (p = cmdLine; *p != '\0'; p++) {
if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
size++;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
}
}
/* Make sure we don't call ckalloc through the (not yet initialized) stub table */
#undef Tcl_Alloc
#undef Tcl_DbCkalloc
argSpace = ckalloc(size * sizeof(char *)
+ (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
argv = (TCHAR **) argSpace;
argSpace += size * (sizeof(char *)/sizeof(TCHAR));
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
argv[argc] = arg = argSpace;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
inquote = 0;
slashes = 0;
while (1) {
copy = 1;
while (*p == '\\') {
slashes++;
p++;
}
if (*p == '"') {
if ((slashes & 1) == 0) {
copy = 0;
if ((inquote) && (p[1] == '"')) {
p++;
copy = 1;
} else {
inquote = !inquote;
}
}
slashes >>= 1;
}
while (slashes) {
*arg = '\\';
arg++;
slashes--;
}
if ((*p == '\0') || (!inquote &&
((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
break;
}
if (copy != 0) {
*arg = *p;
arg++;
}
p++;
|
| ︙ | ︙ |
Changes to win/tclWinChan.c.
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
DWORD err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
| > | | > | | < | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
DWORD err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
channel = NULL;
switch (FileGetType(handle)) {
case FILE_TYPE_SERIAL:
/*
* Reopen channel for OVERLAPPED operation. Normally this shouldn't
* fail, because the channel exists.
*/
handle = TclWinSerialReopen(handle, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
if (interp != (Tcl_Interp *) NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't reopen serial \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
channel = TclWinOpenSerialChannel(handle, channelName,
channelPermissions);
break;
case FILE_TYPE_CONSOLE:
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 |
default:
/*
* The handle is of an unknown type, probably /dev/nul equivalent or
* possibly a closed handle.
*/
channel = NULL;
| | | > | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
default:
/*
* The handle is of an unknown type, probably /dev/nul equivalent or
* possibly a closed handle.
*/
channel = NULL;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": bad file type",
TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE",
NULL);
break;
}
return channel;
}
|
| ︙ | ︙ |
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | # define CP_WINUNICODE CP_WINANSI # undef Tcl_WinTCharToUtf # define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) # undef Tcl_WinUtfToTChar # define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) #endif /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init * declaration is in the source file itself, which is only accessed when we * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. */ | > > > > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
# define CP_WINUNICODE CP_WINANSI
# undef Tcl_WinTCharToUtf
# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c)
# undef Tcl_WinUtfToTChar
# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c)
#endif
#if !defined(NDEBUG)
/* test POKE server Implemented for debug mode only */
# undef CBF_FAIL_POKES
# define CBF_FAIL_POKES 0
#endif
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
* declaration is in the source file itself, which is only accessed when we
* are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE
* EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON.
*/
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
{
if (!Tcl_InitStubs(interp, "8.1", 0)) {
return TCL_ERROR;
}
#ifdef UNICODE
if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) {
| > | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
{
if (!Tcl_InitStubs(interp, "8.1", 0)) {
return TCL_ERROR;
}
#ifdef UNICODE
if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Win32s and Windows 9x are not supported platforms", -1));
return TCL_ERROR;
}
#endif
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
}
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
if (uFmt == CF_TEXT) {
returnString =
Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
} else {
returnString = (char *)
Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len);
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
if (uFmt == CF_TEXT) {
returnString =
Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
} else {
returnString = (char *)
Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len);
len = sizeof(TCHAR) * len + 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
} else {
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
} else {
Tcl_DString ds;
Tcl_Obj *variableObjPtr;
Tcl_WinTCharToUtf(utilString, -1, &ds);
variableObjPtr = Tcl_GetVar2Ex(
convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
if (uFmt == CF_TEXT) {
returnString = Tcl_GetStringFromObj(
variableObjPtr, &len);
} else {
returnString = (char *) Tcl_GetUnicodeFromObj(
variableObjPtr, &len);
len = sizeof(TCHAR) * len + 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
uFmt, 0);
} else {
ddeReturn = NULL;
}
Tcl_DStringFree(&ds);
}
}
Tcl_DStringFree(&dString);
}
return ddeReturn;
#if !CBF_FAIL_POKES
case XTYP_POKE:
/*
* This is a poke for a Tcl variable, only implemented in
* debug/UNICODE mode.
*/
ddeReturn = DDE_FNOTPROCESSED;
if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
return ddeReturn;
}
for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
&& (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
/*
* Empty loop body.
*/
}
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
Tcl_DString ds;
Tcl_Obj *variableObjPtr;
len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1);
utilString = (TCHAR *) Tcl_DStringValue(&dString);
DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
Tcl_WinTCharToUtf(utilString, -1, &ds);
utilString = (TCHAR *) DdeAccessData(hData, &dlen);
if (uFmt == CF_TEXT) {
variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
} else {
variableObjPtr = Tcl_NewUnicodeObj(utilString, -1);
}
Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
variableObjPtr, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dString);
ddeReturn = (HDDEDATA) DDE_FACK;
}
return ddeReturn;
#endif
case XTYP_EXECUTE: {
/*
* Execute this script. The results will be saved into a list object
* which will be retreived later. See ExecuteRemoteObject.
*/
Tcl_Obj *returnPackagePtr;
|
| ︙ | ︙ | |||
943 944 945 946 947 948 949 |
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
| > | | > > > | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 |
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
Tcl_DString dString;
Tcl_WinTCharToUtf(name, -1, &dString);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no registered server named \"%s\"", Tcl_DStringValue(&dString)));
Tcl_DStringFree(&dString);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
}
return TCL_ERROR;
}
*ddeConvPtr = ddeConv;
return TCL_OK;
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 |
}
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1));
} else {
Tcl_ResetResult(interp);
}
break;
case DDE_EXECUTE: {
int dataLength;
| > > > > | | | | | | | > > > > | > | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 |
}
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
#ifdef UNICODE
Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1));
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
#endif
} else {
Tcl_ResetResult(interp);
}
break;
case DDE_EXECUTE: {
int dataLength;
const Tcl_UniChar *dataString;
if (flags & DDE_FLAG_BINARY) {
dataString = (const Tcl_UniChar *)
Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
dataString =
Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength);
dataLength = (dataLength + 1) * sizeof(Tcl_UniChar);
}
if (dataLength <= 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
break;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
break;
}
ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString,
(DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0);
if (ddeData != NULL) {
if (flags & DDE_FLAG_ASYNC) {
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
(flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeReturn == 0) {
SetDdeError(interp);
result = TCL_ERROR;
}
}
DdeFreeDataHandle(ddeData);
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
break;
}
case DDE_REQUEST: {
#ifdef UNICODE
const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
&length);
#else
const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
&length);
#endif
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 |
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
| | | > | | > > > > | > | | | | 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
(flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp);
} else {
tmp >>= 1;
if (tmp && !dataString[(tmp-1)]) {
--tmp;
}
returnObjPtr = Tcl_NewUnicodeObj(dataString,
(int) tmp);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
Tcl_SetObjResult(interp, returnObjPtr);
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
break;
}
case DDE_POKE: {
#ifdef UNICODE
const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2],
&length);
#else
const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2],
&length);
#endif
BYTE *dataString;
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length);
} else {
dataString = (BYTE *)
Tcl_GetUnicodeFromObj(objv[firstArg + 3], &length);
length = 2 * length + 1;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(dataString, (DWORD) length,
hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
* compile an object, producing a bytecode structure that refers
* to other objects owned by the target interp. If the target
* interp is then deleted, the bytecode structure would be
* referring to deallocated objects.
*/
if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
| | | | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 |
* compile an object, producing a bytecode structure that refers
* to other objects owned by the target interp. If the target
* interp is then deleted, the bytecode structure would be
* referring to deallocated objects.
*/
if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj(
"permission denied: a handler procedure must be"
" defined for use in a safe interp", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
NULL);
result = TCL_ERROR;
}
if (result == TCL_OK) {
if (objc == 1)
|
| ︙ | ︙ | |||
1708 1709 1710 1711 1712 1713 1714 |
Tcl_NewStringObj("invalid data returned from server", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
| | | | | | > < | | > | > | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 |
Tcl_NewStringObj("invalid data returned from server", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length);
ddeItemData = DdeCreateDataHandle(ddeInstance,
(BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandle(ddeInstance,
TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL);
}
}
Tcl_DecrRefCount(objPtr);
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
Tcl_UniChar *ddeDataString;
/*
* The return handle has a two or four element list in it. The
* first element is the return code (TCL_OK, TCL_ERROR, etc.).
* The second is the result of the script. If the return code
* is TCL_ERROR, then the third element is the value of the
* variable "errorCode", and the fourth is the value of the
* variable "errorInfo".
*/
resultPtr = Tcl_NewObj();
length = DdeGetData(ddeData, NULL, 0, 0);
ddeDataString = ckalloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
length = (length >> 1) - 1;
resultPtr = Tcl_NewUnicodeObj(ddeDataString, length);
ckfree(ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
goto invalidServerResponse;
}
if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
|
| ︙ | ︙ |
Changes to win/tclWinError.c.
| ︙ | ︙ | |||
406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
}
OutputDebugStringW(msgString);
} else {
vfprintf(stderr, format, argList);
fprintf(stderr, "\n");
fflush(stderr);
}
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
| > > > > > > | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
}
OutputDebugStringW(msgString);
} else {
vfprintf(stderr, format, argList);
fprintf(stderr, "\n");
fflush(stderr);
}
# if defined(__GNUC__)
__builtin_trap();
# else
DebugBreak();
# endif
abort();
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 |
path = (const char *) nativePath;
Tcl_DStringInit(&buffer);
len = strlen(path);
find = Tcl_DStringAppend(&buffer, path, len);
if ((len > 0) && (find[len - 1] != '\\')) {
| | | | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 |
path = (const char *) nativePath;
Tcl_DStringInit(&buffer);
len = strlen(path);
find = Tcl_DStringAppend(&buffer, path, len);
if ((len > 0) && (find[len - 1] != '\\')) {
TclDStringAppendLiteral(&buffer, "\\");
}
find = TclDStringAppendLiteral(&buffer, "*.*");
handle = FindFirstFileA(find, &data);
if (handle != INVALID_HANDLE_VALUE) {
while (1) {
if ((strcmp(data.cFileName, ".") != 0)
&& (strcmp(data.cFileName, "..") != 0)) {
/*
* Found something in this directory.
|
| ︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 |
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
| | | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 |
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
/*
*----------------------------------------------------------------------
*
* GetWinFileAttributes --
*
|
| ︙ | ︙ | |||
1645 1646 1647 1648 1649 1650 1651 |
int pathc, i;
Tcl_Obj *splitPath;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
| > | | < | 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
int pathc, i;
Tcl_Obj *splitPath;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
Tcl_GetString(fileName)));
errno = ENOENT;
Tcl_PosixError(interp);
}
goto cleanup;
}
/*
|
| ︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 |
if (interp != NULL) {
StatError(interp, fileName);
}
goto cleanup;
}
nativeName = data.cAlternateFileName;
if (longShort) {
| | | | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 |
if (interp != NULL) {
StatError(interp, fileName);
}
goto cleanup;
}
nativeName = data.cAlternateFileName;
if (longShort) {
if (data.cFileName[0] != '\0') {
nativeName = data.cFileName;
}
} else {
if (data.cAlternateFileName[0] == '\0') {
nativeName = (TCHAR *) data.cFileName;
}
}
/*
* Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
* to dereference nativeName as a Unicode string. I have proven to
|
| ︙ | ︙ | |||
1937 1938 1939 1940 1941 1942 1943 |
static int
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. */
{
| > | | < | 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 |
static int
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_SetObjResult(interp, Tcl_ObjPrintf(
"cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
tclpFileAttrStrings[objIndex], Tcl_GetString(fileName)));
errno = EINVAL;
Tcl_PosixError(interp);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 | * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" #include "tclFileSystem.h" #include <winioctl.h> | > < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <sys/stat.h> #include "tclWinInt.h" #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> #include <lm.h> /* For TclpGetUserHome(). */ /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). */ |
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | static int NativeDev(const TCHAR *path); static int NativeStat(const TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks); static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); static int NativeIsExec(const TCHAR *path); static int NativeReadReparse(const TCHAR *LinkDirectory, | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | static int NativeDev(const TCHAR *path); static int NativeStat(const TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks); static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); static int NativeIsExec(const TCHAR *path); static int NativeReadReparse(const TCHAR *LinkDirectory, REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess); static int NativeWriteReparse(const TCHAR *LinkDirectory, REPARSE_DATA_BUFFER *buffer); static int NativeMatchType(int isDrive, DWORD attr, const TCHAR *nativeName, Tcl_GlobTypeData *types); static int WinIsDrive(const char *name, int nameLen); static int WinIsReserved(const char *path); static Tcl_Obj * WinReadLink(const TCHAR *LinkSource); |
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
TclWinSymLinkCopyDirectory(
const TCHAR *linkOrigPath, /* Existing junction - reparse point */
const TCHAR *linkCopyPath) /* Will become a duplicate junction */
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
TclWinSymLinkCopyDirectory(
const TCHAR *linkOrigPath, /* Existing junction - reparse point */
const TCHAR *linkCopyPath) /* Will become a duplicate junction */
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
if (NativeReadReparse(linkOrigPath, reparseBuffer, GENERIC_READ)) {
return -1;
}
return NativeWriteReparse(linkCopyPath, reparseBuffer);
}
/*
*--------------------------------------------------------------------
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
Tcl_DString ds;
const char *copy;
attr = GetFileAttributes(linkDirPath);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
goto invalidError;
}
| | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
Tcl_DString ds;
const char *copy;
attr = GetFileAttributes(linkDirPath);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
goto invalidError;
}
if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) {
return NULL;
}
switch (reparseBuffer->ReparseTag) {
case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
case IO_REPARSE_TAG_SYMBOLIC_LINK:
case IO_REPARSE_TAG_MOUNT_POINT:
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
*
*--------------------------------------------------------------------
*/
static int
NativeReadReparse(
const TCHAR *linkDirPath, /* The junction to read */
| | > | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 |
*
*--------------------------------------------------------------------
*/
static int
NativeReadReparse(
const TCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
hFile = CreateFile(linkDirPath, desiredAccess, 0, NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
}
/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
*
| > > > > > > > > > > | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
#if defined(__GNUC__)
__builtin_trap();
#elif defined(_WIN64)
__debugbreak();
#elif defined(_MSC_VER)
_asm {int 3}
#else
DebugBreak();
#endif
abort();
}
/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
*
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 |
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
| | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 |
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
dirName = Tcl_DStringValue(&dsOrig);
/*
* We need to check all files in the directory, so we append '*.*' to
* the path, unless the pattern we've been given is rather simple,
* when we can use that instead.
*/
if (strpbrk(pattern, "[]\\") == NULL) {
/*
* The pattern is a simple one containing just '*' and/or '?'.
* This means we can get the OS to help us, by passing it the
* pattern.
*/
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
native = Tcl_WinUtfToTChar(dirName, -1, &ds);
if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
handle = FindFirstFile(native, &data);
} else {
/*
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
Tcl_DStringFree(&dsOrig);
return TCL_OK;
}
TclWinConvertError(err);
if (interp != NULL) {
| | | | < | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 |
Tcl_DStringFree(&dsOrig);
return TCL_OK;
}
TclWinConvertError(err);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
return TCL_ERROR;
}
Tcl_DStringFree(&ds);
/*
|
| ︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 |
/*
* User exists but has no home dir. Return
* "{Windows Drive}:/users/default".
*/
GetWindowsDirectoryW(buf, MAX_PATH);
Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
| | | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 |
/*
* User exists but has no home dir. Return
* "{Windows Drive}:/users/default".
*/
GetWindowsDirectoryW(buf, MAX_PATH);
Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
TclDStringAppendLiteral(bufferPtr, "/users/default");
}
result = Tcl_DStringValue(bufferPtr);
NetApiBufferFree((void *) uiPtr);
}
Tcl_DStringFree(&ds);
}
if (wDomain != NULL) {
|
| ︙ | ︙ | |||
1771 1772 1773 1774 1775 1776 1777 |
{
int len = _tcslen(path);
if (len < 5) {
return 0;
}
| | | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 |
{
int len = _tcslen(path);
if (len < 5) {
return 0;
}
if (path[len-4] != '.') {
return 0;
}
if ((_tcsicmp(path+len-3, TEXT("exe")) == 0)
|| (_tcsicmp(path+len-3, TEXT("com")) == 0)
|| (_tcsicmp(path+len-3, TEXT("bat")) == 0)) {
return 1;
|
| ︙ | ︙ | |||
1852 1853 1854 1855 1856 1857 1858 |
TCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
| > | | | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 |
TCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
/*
* Watch for the weird Windows c:\\UNC syntax.
*/
|
| ︙ | ︙ | |||
2062 2063 2064 2065 2066 2067 2068 |
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
* Add terminating backslash to fullpath or GetVolumeInformation()
* won't work.
*/
| | | 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 |
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
* Add terminating backslash to fullpath or GetVolumeInformation()
* won't work.
*/
fullPath = TclDStringAppendLiteral(&ds, "\\");
p = fullPath + Tcl_DStringLength(&ds);
} else {
p++;
}
nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
dw = (DWORD) -1;
GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0);
|
| ︙ | ︙ | |||
2522 2523 2524 2525 2526 2527 2528 | } /* * This is usually the '/' in 'c:/' at end of * string. */ | | | | | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 |
}
/*
* This is usually the '/' in 'c:/' at end of
* string.
*/
TclDStringAppendLiteral(&dsNorm, "/");
} else {
char *nativeName;
if (fData.cFileName[0] != '\0') {
nativeName = fData.cFileName;
} else {
nativeName = fData.cAlternateFileName;
}
FindClose(handle);
TclDStringAppendLiteral(&dsNorm, "/");
Tcl_DStringAppend(&dsNorm, nativeName, -1);
}
}
}
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
/*
* The default directory in which the init.tcl file is expected to be found.
*/
static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir;
static ProcessGlobalValue defaultLibraryDir =
{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
static int ToUtf(const WCHAR *wSrc, char *dst);
/*
*---------------------------------------------------------------------------
*
| > > > > | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
/*
* The default directory in which the init.tcl file is expected to be found.
*/
static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir;
static ProcessGlobalValue defaultLibraryDir =
{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
static TclInitProcessGlobalValueProc InitializeSourceLibraryDir;
static ProcessGlobalValue sourceLibraryDir =
{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib);
static int ToUtf(const WCHAR *wSrc, char *dst);
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
void
TclpInitLibraryPath(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
| | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
void
TclpInitLibraryPath(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
pathPtr = Tcl_NewObj();
/*
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
/*
* Look for the library in its default location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&defaultLibraryDir));
*encodingPtr = NULL;
bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
*valuePtr = ckalloc((*lengthPtr) + 1);
memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
| > > > > > > > | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 |
/*
* Look for the library in its default location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&defaultLibraryDir));
/*
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
*valuePtr = ckalloc((*lengthPtr) + 1);
memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
*valuePtr = ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, (size_t) *lengthPtr + 1);
}
/*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
*valuePtr = ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, (size_t) *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
* InitializeSourceLibraryDir --
*
* Locate the Tcl script library default location relative to the
* location of the Tcl DLL as it exists in the build output directory
* associated with the source checkout.
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static void
InitializeSourceLibraryDir(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
char *end, *p;
if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
GetModuleFileNameA(hModule, name, MAX_PATH);
} else {
ToUtf(wName, name);
}
end = strrchr(name, '\\');
*end = '\0';
p = strrchr(name, '\\');
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
*valuePtr = ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, (size_t) *lengthPtr + 1);
}
/*
|
| ︙ | ︙ |
Changes to win/tclWinInt.h.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | #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 | > > > > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | #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 #ifdef _WIN64 # define TCL_I_MODIFIER "I" #else # define TCL_I_MODIFIER "" #endif |
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
| | > | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
HINSTANCE hInstance;
const TCHAR *nativeName;
Tcl_LoadHandle handlePtr;
/*
* First try the full path the user gave us. This is particularly
|
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
hInstance = LoadLibraryEx(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError = GetLastError();
| < | | | | | | | | | | | | > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
hInstance = LoadLibraryEx(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError = GetLastError();
Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
Tcl_GetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
* because Windows seems to only return ERROR_MOD_NOT_FOUND for just
* about any problem, but it's better than nothing. It'd be even
* better if there was a way to get what DLLs
*/
switch (lastError) {
case ERROR_MOD_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL);
goto notFoundMsg;
case ERROR_DLL_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL);
notFoundMsg:
Tcl_AppendToObj(errMsg, "this library or a dependent library"
" could not be found in library path", -1);
break;
case ERROR_PROC_NOT_FOUND:
Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL);
Tcl_AppendToObj(errMsg, "A function specified in the import"
" table could not be resolved by the system. Windows"
" is not telling which one, I'm sorry.", -1);
break;
case ERROR_INVALID_DLL:
Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL);
Tcl_AppendToObj(errMsg, "this library or a dependent library"
" is damaged", -1);
break;
case ERROR_DLL_INIT_FAILED:
Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL);
Tcl_AppendToObj(errMsg, "the library initialization"
" routine failed", -1);
break;
default:
TclWinConvertError(lastError);
Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1);
}
Tcl_SetObjResult(interp, errMsg);
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
proc = (void *) GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
const char *sym2;
Tcl_DStringInit(&ds);
| | > | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
proc = (void *) GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
const char *sym2;
Tcl_DStringInit(&ds);
TclDStringAppendLiteral(&ds, "_");
sym2 = Tcl_DStringAppend(&ds, symbol, -1);
proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
return proc;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 |
{
Tcl_Obj *fileName; /* Name of the temp file. */
Tcl_Obj *tail; /* Tail of the source path. */
Tcl_MutexLock(&dllDirectoryNameMutex);
if (dllDirectoryName == NULL) {
if (InitDLLDirectoryName() == TCL_ERROR) {
| > | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
{
Tcl_Obj *fileName; /* Name of the temp file. */
Tcl_Obj *tail; /* Tail of the source path. */
Tcl_MutexLock(&dllDirectoryNameMutex);
if (dllDirectoryName == NULL) {
if (InitDLLDirectoryName() == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create temporary directory: %s",
Tcl_PosixError(interp)));
Tcl_MutexUnlock(&dllDirectoryNameMutex);
return NULL;
}
}
Tcl_MutexUnlock(&dllDirectoryNameMutex);
/*
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
672 673 674 675 676 677 678 679 680 681 682 683 684 685 |
/*
* Write the file out, doing line translations on the way.
*/
if (contents != NULL) {
DWORD result, length;
const char *p;
/*
* Convert the contents from UTF to native encoding
*/
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
| > > | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
/*
* Write the file out, doing line translations on the way.
*/
if (contents != NULL) {
DWORD result, length;
const char *p;
int toCopy;
/*
* Convert the contents from UTF to native encoding
*/
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
toCopy = Tcl_DStringLength(&dstring);
for (p = native; toCopy > 0; p++, toCopy--) {
if (*p == '\n') {
length = p - native;
if (length > 0) {
if (!WriteFile(handle, native, length, &result, NULL)) {
goto error;
}
}
|
| ︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 |
}
} else {
DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput,
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
| > | | | 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
}
} else {
DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput,
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdInput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate input handle: %s",
Tcl_PosixError(interp)));
goto end;
}
if (outputHandle == INVALID_HANDLE_VALUE) {
/*
* If handle was not set, output should be sent to an infinitely deep
* sink. Under Windows 95, some 16 bit applications cannot have stdout
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 |
}
} else {
DuplicateHandle(hProcess, outputHandle, hProcess,
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
| > | | > | | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 |
}
} else {
DuplicateHandle(hProcess, outputHandle, hProcess,
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate output handle: %s",
Tcl_PosixError(interp)));
goto end;
}
if (errorHandle == INVALID_HANDLE_VALUE) {
/*
* If handle was not set, errors should be sent to an infinitely deep
* sink.
*/
startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate error handle: %s",
Tcl_PosixError(interp)));
goto end;
}
/*
* If we do not have a console window, then we must run DOS and WIN32
* console mode applications as detached processes. This tells the loader
* that the child application should not inherit the console, and that it
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 | * console application, and then run that hidden console as a * detached process. */ startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; | | | | | 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 |
* 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;
}
} 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;
}
}
/*
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
| | | | | | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine),
NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
&procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
argv[0], Tcl_PosixError(interp)));
goto end;
}
/*
* This wait is used to force the OS to give some time to the DOS process.
*/
|
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 |
}
break;
}
Tcl_DStringFree(&nameBuf);
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
| | | | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 |
}
break;
}
Tcl_DStringFree(&nameBuf);
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
originalName, Tcl_PosixError(interp)));
return APPL_NONE;
}
if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) {
/*
* Replace long path name of executable with short path name for
* 16-bit applications. Otherwise the application may not be able to
|
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
Tcl_DStringInit(&ds);
/*
* Prime the path. Add a space separator if we were primed with something.
*/
| | | | | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 |
Tcl_DStringInit(&ds);
/*
* Prime the path. Add a space separator if we were primed with something.
*/
TclDStringAppendDString(&ds, linePtr);
if (Tcl_DStringLength(linePtr) > 0) {
TclDStringAppendLiteral(&ds, " ");
}
for (i = 0; i < argc; i++) {
if (i == 0) {
arg = executable;
} else {
arg = argv[i];
TclDStringAppendLiteral(&ds, " ");
}
quote = 0;
if (arg[0] == '\0') {
quote = 1;
} else {
int count;
Tcl_UniChar ch;
for (start = arg; *start != '\0'; start += count) {
count = Tcl_UtfToUniChar(start, &ch);
if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */
quote = 1;
break;
}
}
}
if (quote) {
TclDStringAppendLiteral(&ds, "\"");
}
start = arg;
for (special = arg; ; ) {
if ((*special == '\\') && (special[1] == '\\' ||
special[1] == '"' || (quote && special[1] == '\0'))) {
Tcl_DStringAppend(&ds, start, (int) (special - start));
start = special;
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 |
}
}
Tcl_DStringAppend(&ds, start, (int) (special - start));
start = special;
}
if (*special == '"') {
Tcl_DStringAppend(&ds, start, (int) (special - start));
| | | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 |
}
}
Tcl_DStringAppend(&ds, start, (int) (special - start));
start = special;
}
if (*special == '"') {
Tcl_DStringAppend(&ds, start, (int) (special - start));
TclDStringAppendLiteral(&ds, "\\\"");
start = special + 1;
}
if (*special == '\0') {
break;
}
special++;
}
Tcl_DStringAppend(&ds, start, (int) (special - start));
if (quote) {
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
|
| ︙ | ︙ | |||
1667 1668 1669 1670 1671 1672 1673 |
sec.nLength = sizeof(SECURITY_ATTRIBUTES);
sec.lpSecurityDescriptor = NULL;
sec.bInheritHandle = FALSE;
if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
TclWinConvertError(GetLastError());
| | | | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
sec.nLength = sizeof(SECURITY_ATTRIBUTES);
sec.lpSecurityDescriptor = NULL;
sec.bInheritHandle = FALSE;
if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"pipe creation failed: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
*rchan = Tcl_MakeFileChannel((ClientData) readHandle, TCL_READABLE);
Tcl_RegisterChannel(interp, *rchan);
*wchan = Tcl_MakeFileChannel((ClientData) writeHandle, TCL_WRITABLE);
|
| ︙ | ︙ | |||
1705 1706 1707 1708 1709 1710 1711 1712 |
void
TclGetAndDetachPids(
Tcl_Interp *interp,
Tcl_Channel chan)
{
PipeInfo *pipePtr;
const Tcl_ChannelType *chanTypePtr;
int i;
| > < | > > > | < | > | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 |
void
TclGetAndDetachPids(
Tcl_Interp *interp,
Tcl_Channel chan)
{
PipeInfo *pipePtr;
const Tcl_ChannelType *chanTypePtr;
Tcl_Obj *pidsObj;
int i;
/*
* Punt if the channel is not a command channel.
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj,
Tcl_NewWideIntObj((unsigned)
TclpGetPid(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/*
|
| ︙ | ︙ | |||
1869 1870 1871 1872 1873 1874 1875 |
pipePtr->validMask &= ~TCL_READABLE;
pipePtr->readFile = NULL;
}
if ((!flags || flags & TCL_CLOSE_WRITE)
&& (pipePtr->writeFile != NULL)) {
if (pipePtr->writeThread) {
/*
| | | | > > > > > > > > > > > > | > > | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 |
pipePtr->validMask &= ~TCL_READABLE;
pipePtr->readFile = NULL;
}
if ((!flags || flags & TCL_CLOSE_WRITE)
&& (pipePtr->writeFile != NULL)) {
if (pipePtr->writeThread) {
/*
* Wait for the writer thread to finish the current buffer, then
* terminate the thread and close the handles. If the channel is
* nonblocking but blocked during exit, bail out since the worker
* thread is not interruptible and we want TIP#398-fast-exit.
*/
if (TclInExit()
&& (pipePtr->flags & PIPE_ASYNC)) {
/* give it a chance to leave honorably */
SetEvent(pipePtr->stopWriter);
if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) {
return EAGAIN;
}
} else {
WaitForSingleObject(pipePtr->writable, INFINITE);
}
/*
* The thread may already have closed on it's own. Check its exit
* code.
*/
GetExitCodeThread(pipePtr->writeThread, &exitCode);
|
| ︙ | ︙ | |||
2622 2623 2624 2625 2626 2627 2628 |
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
int i;
Tcl_Obj *resultPtr;
| < < | < | > | 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 |
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
int i;
Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid()));
} else {
chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
Tcl_NewWideIntObj((unsigned)
TclpGetPid(pipePtr->pidPtr[i])));
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 |
waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
* The start event was not signaled. It might be the stop event or
* an error, so exit.
*/
break;
}
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
| > > > > | 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 |
waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
if (waitResult != (WAIT_OBJECT_0 + 1)) {
/*
* The start event was not signaled. It might be the stop event or
* an error, so exit.
*/
if (waitResult == WAIT_OBJECT_0) {
SetEvent(infoPtr->writable);
}
break;
}
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
|
| ︙ | ︙ |
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT #if !defined(_WIN64) && defined(BUILD_tcl) /* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif /* * We must specify the lower version we intend to support. * * WINVER = 0x0500 means Windows 2000 and above |
| ︙ | ︙ | |||
534 535 536 537 538 539 540 | * The following defines map from standard socket names to our internal * wrappers that redirect through the winSock function table (see the * file tclWinSock.c). */ #define getservbyname TclWinGetServByName #define getsockopt TclWinGetSockOpt | < | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 | * The following defines map from standard socket names to our internal * wrappers that redirect through the winSock function table (see the * file tclWinSock.c). */ #define getservbyname TclWinGetServByName #define getsockopt TclWinGetSockOpt #define setsockopt TclWinSetSockOpt /* This type is not defined in the Windows headers */ #define socklen_t int /* * The following macros have trivial definitions, allowing generic code to |
| ︙ | ︙ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * 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. */ #undef STATIC_BUILD | | | | | | | | | | < < < < < < < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | * 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. */ #undef STATIC_BUILD #undef USE_TCL_STUBS #define USE_TCL_STUBS #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include <stdlib.h> #ifndef UNICODE # undef Tcl_WinTCharToUtf # define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) # undef Tcl_WinUtfToTChar # define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) #endif /* !UNICODE */ /* * Ensure that we can say which registry is being accessed. */ #ifndef KEY_WOW64_64KEY # define KEY_WOW64_64KEY (0x0100) #endif #ifndef KEY_WOW64_32KEY # define KEY_WOW64_32KEY (0x0200) #endif /* * The maximum length of a sub-key name. */ #ifndef MAX_KEY_LENGTH # define MAX_KEY_LENGTH 256 #endif /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the * Registry_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 /* * The following macros convert between different endian ints. */ #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) |
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
int
Registry_Init(
Tcl_Interp *interp)
{
Tcl_Command cmd;
| | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
int
Registry_Init(
Tcl_Interp *interp)
{
Tcl_Command cmd;
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvide(interp, "registry", "1.3.0");
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 |
}
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
Tcl_WinUtfToTChar(valueName, length, &ds);
result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
| > | | < | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
}
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
Tcl_WinUtfToTChar(valueName, length, &ds);
result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to delete value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
result = TCL_OK;
}
RegCloseKey(key);
return result;
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
| | > | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
TCHAR buffer[MAX_KEY_LENGTH];
/* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
Tcl_Obj *resultPtr; /* List of subkeys being accumulated */
int result = TCL_OK; /* Return value from this command */
Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 |
bufSize = MAX_KEY_LENGTH;
result = RegEnumKeyEx(key, index, buffer, &bufSize,
NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
| | | | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
bufSize = MAX_KEY_LENGTH;
result = RegEnumKeyEx(key, index, buffer, &bufSize,
NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to enumerate subkeys of \"%s\": ",
Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
break;
}
Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds);
name = Tcl_DStringValue(&ds);
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 |
nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
| > | | < | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
result = RegQueryValueEx(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get type of value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
return TCL_ERROR;
}
/*
* Set the type into the result. Watch out for unknown types. If we don't
* know about the type, just use the numeric value.
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 |
while (result == ERROR_MORE_DATA) {
/*
* The Windows docs say that in this error case, we just need to
* expand our buffer and request more data. Required for
* HKEY_PERFORMANCE_DATA
*/
| | > | | < | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
while (result == ERROR_MORE_DATA) {
/*
* The Windows docs say that in this error case, we just need to
* expand our buffer and request more data. Required for
* HKEY_PERFORMANCE_DATA
*/
length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR));
Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR));
result = RegQueryValueEx(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
Tcl_DStringFree(&data);
return TCL_ERROR;
}
/*
* If the data is a 32-bit quantity, store it as an integer object. If it
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 | /* * Multistrings are stored as an array of null-terminated strings, * terminated by two null characters. Also do a bounds check in case * we get bogus data. */ | | < > | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 |
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((Tcl_UniChar *) p) != 0) {
Tcl_UniChar *up;
Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
up = (Tcl_UniChar *) p;
while (*up++ != 0) {/* empty body */}
p = (char *) up;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
Tcl_DStringResult(interp, &buf);
|
| ︙ | ︙ | |||
885 886 887 888 889 890 891 |
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
| | < | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 |
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR)));
index = 0;
result = TCL_OK;
if (patternObj) {
pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
}
}
}
} else {
rootName = name;
}
if (!rootName) {
| | | | 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
}
}
}
} else {
rootName = name;
}
if (!rootName) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad key \"%s\": must start with a valid root", name));
Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL);
return TCL_ERROR;
}
/*
* Split the root into root and subkey portions.
*/
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 |
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
| | < | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR)));
mode = saveMode;
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 |
if (mode && regDeleteKeyExProc) {
result = regDeleteKeyExProc(startKey, keyName, mode, 0);
} else {
result = RegDeleteKey(startKey, keyName);
}
break;
} else if (result == ERROR_SUCCESS) {
| | | | 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
if (mode && regDeleteKeyExProc) {
result = regDeleteKeyExProc(startKey, keyName, mode, 0);
} else {
result = RegDeleteKey(startKey, keyName);
}
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey,
(const TCHAR *) Tcl_DStringValue(&subkey), mode);
}
}
Tcl_DStringFree(&subkey);
RegCloseKey(hKey);
return result;
}
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 |
if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
| | | > > | | < < < | | | | | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
value = ConvertDWORD((DWORD) type, (DWORD) value);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
int objc, i;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
/*
* Append the elements as null terminated strings. Note that we must
* not assume the length of the string in case there are embedded
* nulls, which aren't allowed in REG_MULTI_SZ values.
*/
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
const char *bytes = Tcl_GetStringFromObj(objv[i], &length);
Tcl_DStringAppend(&data, bytes, length);
/*
* Add a null character to separate this value from the next.
*/
Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
const char *data = Tcl_GetStringFromObj(dataObj, &length);
data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
/*
* Include the null in the length, padding if needed for Unicode.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
length = Tcl_DStringLength(&buf) + 1;
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, (BYTE *) data, (DWORD) length);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
/*
* Store binary data in the registry.
*/
data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
result = RegSetValueEx(key, (TCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) length);
}
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
|
| ︙ | ︙ | |||
1528 1529 1530 1531 1532 1533 1534 |
*/
static DWORD
ConvertDWORD(
DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
DWORD value) /* The value to be converted. */
{
| | > | | 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 |
*/
static DWORD
ConvertDWORD(
DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
DWORD value) /* The value to be converted. */
{
const DWORD order = 1;
DWORD localType;
/*
* Check to see if the low bit is in the first byte.
*/
localType = (*((const char *) &order) == 1)
? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
*/
static unsigned int
SerialGetMilliseconds(void)
{
Tcl_Time time;
| | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
*/
static unsigned int
SerialGetMilliseconds(void)
{
Tcl_Time time;
Tcl_GetTime(&time);
return (time.sec * 1000 + time.usec / 1000);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 |
/*
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
| < < | < < < | | > < < | < < < < < | < < < | 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
/*
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
native = Tcl_WinUtfToTChar(value, -1, &ds);
result = BuildCommDCB(native, &dcb);
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -mode: should be baud,parity,data,stop",
value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
}
return TCL_ERROR;
}
/*
* Default settings for serial communications.
*/
dcb.fBinary = TRUE;
dcb.fErrorChar = FALSE;
dcb.fNull = FALSE;
dcb.fAbortOnError = FALSE;
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
return TCL_OK;
}
/*
* Option -handshake none|xonxoff|rtscts|dtrdsr
*/
if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
/*
* Reset all handshake options. DTR and RTS are ON by default.
*/
dcb.fOutX = dcb.fInX = FALSE;
|
| ︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 |
dcb.fOutxCtsFlow = TRUE;
dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
} else if (strncasecmp(value, "DTRDSR", vlen) == 0) {
dcb.fOutxDsrFlow = TRUE;
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp != NULL) {
| | | | < < | < < < < < | < < < > | | < | 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 |
dcb.fOutxCtsFlow = TRUE;
dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
} else if (strncasecmp(value, "DTRDSR", vlen) == 0) {
dcb.fOutxDsrFlow = TRUE;
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -handshake: must be one of"
" xonxoff, rtscts, dtrdsr or none", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL);
}
return TCL_ERROR;
}
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
return TCL_OK;
}
/*
* Option -xchar {\x11 \x13}
*/
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (argc != 2) {
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 |
goto badXchar;
}
dcb.XoffChar = (char) character;
}
ckfree(argv);
if (!SetCommState(infoPtr->handle, &dcb)) {
| < < | < < < | | | > | > | > | | | | | 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 |
goto badXchar;
}
dcb.XoffChar = (char) character;
}
ckfree(argv);
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
int i, result = TCL_OK;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -ttycontrol: should be "
"a list of signal,value pairs", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
for (i = 0; i < argc - 1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
result = TCL_ERROR;
break;
}
if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETDTR : CLRDTR))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set DTR signal", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
result = TCL_ERROR;
break;
}
} else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETRTS : CLRRTS))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set RTS signal", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
result = TCL_ERROR;
break;
}
} else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle,
(DWORD) (flag ? SETBREAK : CLRBREAK))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't set BREAK signal", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", NULL);
}
result = TCL_ERROR;
break;
}
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal name \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL",
NULL);
}
result = TCL_ERROR;
break;
}
}
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
ckfree(argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
| | | | > | | < < | < < < < < | < < < | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
ckfree(argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -sysbuffer: should be "
"a list of one or two integers > 0", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL);
}
return TCL_ERROR;
}
if (!SetupComm(infoPtr->handle, inSize, outSize)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't setup comm buffers: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
infoPtr->sysBufRead = inSize;
infoPtr->sysBufWrite = outSize;
/*
* Adjust the handshake limits. Yes, the XonXoff limits seem to
* influence even hardware handshake.
*/
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
return TCL_OK;
}
/*
* Option -pollinterval msec
*/
|
| ︙ | ︙ | |||
2016 2017 2018 2019 2020 2021 2022 |
if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
return TCL_ERROR;
}
tout.ReadTotalTimeoutConstant = msec;
if (!SetCommTimeouts(infoPtr->handle, &tout)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
| > | | > > > > > > > > > > > > > > > > | 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 |
if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
return TCL_ERROR;
}
tout.ReadTotalTimeoutConstant = msec;
if (!SetCommTimeouts(infoPtr->handle, &tout)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't set comm timeouts: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
getStateFailed:
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
setStateFailed:
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't set comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* SerialGetOptionProc --
*
|
| ︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 |
char parity;
const char *stop;
char buf[2 * TCL_INTEGER_SPACE + 16];
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
| | | | 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 |
char parity;
const char *stop;
char buf[2 * TCL_INTEGER_SPACE + 16];
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
valid = 1;
parity = 'n';
if (dcb.Parity <= 4) {
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 |
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
char buf[4];
valid = 1;
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
| | | | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
char buf[4];
valid = 1;
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
sprintf(buf, "%c", dcb.XonChar);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%c", dcb.XoffChar);
Tcl_DStringAppendElement(dsPtr, buf);
|
| ︙ | ︙ | |||
2233 2234 2235 2236 2237 2238 2239 |
if (len>4 && strncmp(optionName, "-ttystatus", len)==0) {
DWORD status;
if (!GetCommModemStatus(infoPtr->handle, &status)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
| | | < > | | < | 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 |
if (len>4 && strncmp(optionName, "-ttystatus", len)==0) {
DWORD status;
if (!GetCommModemStatus(infoPtr->handle, &status)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get tty status: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
valid = 1;
SerialModemStatusStr(status, dsPtr);
}
if (valid) {
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
/*
*----------------------------------------------------------------------
*
* SerialThreadActionProc --
*
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | /* * 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 | < | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | /* * 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 /* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). */ |
| ︙ | ︙ | |||
159 160 161 162 163 164 165 | }; /* * The following structure is what is added to the Tcl event queue when a * socket event occurs. */ | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
};
/*
* The following structure is what is added to the Tcl event queue when a
* socket event occurs.
*/
typedef struct {
Tcl_Event header; /* Information that is standard for all
* events. */
SOCKET socket; /* Socket descriptor that is ready. Used to
* find the SocketInfo structure for the file
* (can't point directly to the SocketInfo
* structure because it could go away while
* the event is queued). */
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 | #define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ #define SOCKET_EOF (1<<1) /* A zero read happened on the * socket. */ #define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ #define SOCKET_PENDING (1<<3) /* A message has been sent for this * socket */ | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */
#define SOCKET_EOF (1<<1) /* A zero read happened on the
* socket. */
#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */
#define SOCKET_PENDING (1<<3) /* A message has been sent for this
* socket */
typedef struct {
HWND hwnd; /* Handle to window for socket messages. */
HANDLE socketThread; /* Thread handling the window */
Tcl_ThreadId threadId; /* Parent thread. */
HANDLE readyEvent; /* Event indicating that a socket event is
* ready. Also used to indicate that the
* socketThread has been initialized and has
* started. */
|
| ︙ | ︙ | |||
216 217 218 219 220 221 222 | int myport, int async); static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | int myport, int async); static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(ClientData instanceData, int action); static Tcl_EventCheckProc SocketCheckProc; |
| ︙ | ︙ | |||
554 555 556 557 558 559 560 |
InitSockets();
Tcl_MutexUnlock(&socketMutex);
if (SocketsEnabled()) {
return TCL_OK;
}
if (interp != NULL) {
| > | < | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 |
InitSockets();
Tcl_MutexUnlock(&socketMutex);
if (SocketsEnabled()) {
return TCL_OK;
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"sockets are not available on this system", -1));
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
* such as TCL_FILE_EVENTS. */
{
SocketInfo *infoPtr;
SocketEvent *eventPtr = (SocketEvent *) evPtr;
int mask = 0, events;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TcpFdList *fds;
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
/*
* Find the specified socket on the socket list.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->sockets->fd == eventPtr->socket) {
break;
}
}
| > > > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
* such as TCL_FILE_EVENTS. */
{
SocketInfo *infoPtr;
SocketEvent *eventPtr = (SocketEvent *) evPtr;
int mask = 0, events;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TcpFdList *fds;
SOCKET newSocket;
address addr;
int len;
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
/*
* Find the specified socket on the socket list.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->sockets->fd == eventPtr->socket) {
break;
}
}
/*
* Discard events that have gone stale.
*/
if (!infoPtr) {
SetEvent(tsdPtr->socketListLock);
return 1;
}
infoPtr->flags &= ~SOCKET_PENDING;
/*
* Handle connection requests directly.
*/
if (infoPtr->readyEvents & FD_ACCEPT) {
for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
/*
* Accept the incoming connection request.
*/
len = sizeof(address);
newSocket = accept(fds->fd, &(addr.sa), &len);
/* On Tcl server sockets with multiple OS fds we loop over the fds trying
* an accept() on each, so we expect INVALID_SOCKET. There are also other
* network stack conditions that can result in FD_ACCEPT but a subsequent
* failure on accept() by the time we get around to it.
* Access to sockets (acceptEventCount, readyEvents) in socketList
* is still protected by the lock (prevents reintroduction of
* SF Tcl Bug 3056775.
*/
if (newSocket == INVALID_SOCKET) {
/* int err = WSAGetLastError(); */
continue;
}
/*
* 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.
*/
infoPtr->acceptEventCount--;
if (infoPtr->acceptEventCount <= 0) {
infoPtr->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 infoPtr and fds.
* If TcpAccept() accepts a socket we must return immediately and let
* SocketCheckProc queue additional FD_ACCEPT events.
*/
TcpAccept(fds, newSocket, addr);
return 1;
}
/* Loop terminated with no sockets accepted; clear the ready mask so
* we can detect the next connection request. Note that connection
* requests are level triggered, so if there is a request already
* pending, a new event will be generated.
*/
infoPtr->acceptEventCount = 0;
infoPtr->readyEvents &= ~(FD_ACCEPT);
SetEvent(tsdPtr->socketListLock);
return 1;
}
SetEvent(tsdPtr->socketListLock);
/*
* Mask off unwanted events and compute the read/write mask so we can
* notify the channel.
*/
events = infoPtr->readyEvents & infoPtr->watchEvents;
|
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
if (SocketsEnabled()) {
/*
* Clean up the OS socket handle. The default Windows setting for a
* socket is SO_DONTLINGER, which does a graceful shutdown in the
* background.
*/
| > > > > | | | > > | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 |
if (SocketsEnabled()) {
/*
* Clean up the OS socket handle. The default Windows setting for a
* socket is SO_DONTLINGER, which does a graceful shutdown in the
* background.
*/
while ( infoPtr->sockets != NULL ) {
TcpFdList *thisfd = infoPtr->sockets;
infoPtr->sockets = thisfd->next;
if (closesocket(thisfd->fd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
ckfree(thisfd);
}
}
/*
* TIP #218. Removed the code removing the structure from the global
* socket list. This is now done by the thread action callbacks, and only
* there. This happens before this code is called. We can free without
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 |
sd = SD_RECEIVE;
break;
case TCL_CLOSE_WRITE:
sd = SD_SEND;
break;
default:
if (interp) {
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 |
sd = SD_RECEIVE;
break;
case TCL_CLOSE_WRITE:
sd = SD_SEND;
break;
default:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Socket close2proc called bidirectionally", -1));
}
return TCL_ERROR;
}
/* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
* TCL_WRITABLE so this should never be called for a server socket. */
if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* AddSocketInfoFd --
*
* This function adds a SOCKET file descriptor to the 'sockets' linked
* list of a SocketInfo structure.
*
* Results:
* None.
*
* Side effects:
* None, except for allocation of memory.
*
*----------------------------------------------------------------------
*/
static void
AddSocketInfoFd(
SocketInfo *infoPtr,
SOCKET socket)
{
TcpFdList *fds = infoPtr->sockets;
if ( fds == NULL ) {
/* Add the first FD */
infoPtr->sockets = ckalloc(sizeof(TcpFdList));
fds = infoPtr->sockets;
} else {
/* Find end of list and append FD */
while ( fds->next != NULL ) {
fds = fds->next;
}
fds->next = ckalloc(sizeof(TcpFdList));
fds = fds->next;
}
/* Populate new FD */
fds->fd = socket;
fds->infoPtr = infoPtr;
fds->next = NULL;
}
/*
*----------------------------------------------------------------------
*
* NewSocketInfo --
*
* This function allocates and initializes a new SocketInfo structure.
*
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
*/
static SocketInfo *
NewSocketInfo(
SOCKET socket)
{
SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo));
| < < < < | > > | 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
*/
static SocketInfo *
NewSocketInfo(
SOCKET socket)
{
SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo));
/* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */
infoPtr->channel = 0;
infoPtr->sockets = NULL;
infoPtr->flags = 0;
infoPtr->watchEvents = 0;
infoPtr->readyEvents = 0;
infoPtr->selectEvents = 0;
infoPtr->acceptEventCount = 0;
infoPtr->acceptProc = NULL;
infoPtr->acceptProcData = NULL;
infoPtr->lastError = 0;
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
*/
infoPtr->nextPtr = NULL;
AddSocketInfoFd(infoPtr, socket);
return infoPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
}
if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
goto error;
}
if (server) {
| < | 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
}
if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
goto error;
}
if (server) {
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, SOCK_STREAM, 0);
if (sock == INVALID_SOCKET) {
TclWinConvertError((DWORD) WSAGetLastError());
continue;
}
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 |
if (infoPtr == NULL) {
/*
* Add this socket to the global list of sockets.
*/
infoPtr = NewSocketInfo(sock);
| < < < < | < < < | 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 |
if (infoPtr == NULL) {
/*
* Add this socket to the global list of sockets.
*/
infoPtr = NewSocketInfo(sock);
/*
* Set up the select mask for connection request events.
*/
infoPtr->selectEvents = FD_ACCEPT;
infoPtr->watchEvents |= FD_ACCEPT;
} else {
AddSocketInfoFd( infoPtr, sock );
}
}
} else {
for (addrPtr = addrlist; addrPtr != NULL;
addrPtr = addrPtr->ai_next) {
for (myaddrPtr = myaddrlist; myaddrPtr != NULL;
myaddrPtr = myaddrPtr->ai_next) {
|
| ︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 |
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
(LPARAM) infoPtr);
return infoPtr;
}
if (interp != NULL) {
| > | | > | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 |
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
(LPARAM) infoPtr);
return infoPtr;
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s",
(errorMsg ? errorMsg : Tcl_PosixError(interp))));
}
if (sock != INVALID_SOCKET) {
closesocket(sock);
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 |
*/
infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async);
if (infoPtr == NULL) {
return NULL;
}
| | | 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 |
*/
infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async);
if (infoPtr == NULL) {
return NULL;
}
sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
infoPtr, (TCL_READABLE | TCL_WRITABLE));
if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel,
"-translation", "auto crlf")) {
Tcl_Close(NULL, infoPtr->channel);
return NULL;
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 |
/*
* Start watching for read/write events on the socket.
*/
infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);
| | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
/*
* Start watching for read/write events on the socket.
*/
infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);
sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
infoPtr, (TCL_READABLE | TCL_WRITABLE));
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf");
return infoPtr->channel;
}
/*
|
| ︙ | ︙ | |||
1510 1511 1512 1513 1514 1515 1516 |
if (infoPtr == NULL) {
return NULL;
}
infoPtr->acceptProc = acceptProc;
infoPtr->acceptProcData = acceptProcData;
| | > | | | > > < < | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
if (infoPtr == NULL) {
return NULL;
}
infoPtr->acceptProc = acceptProc;
infoPtr->acceptProcData = acceptProcData;
sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
infoPtr, 0);
if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
== TCL_ERROR) {
Tcl_Close(NULL, infoPtr->channel);
return NULL;
}
return infoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
* TcpAccept --
*
* Creates a channel for a newly accepted socket connection. This is
* called by SocketEventProc and it in turns calls the registered
* accept function.
*
* Results:
* None.
*
* Side effects:
* Invokes the accept proc which may invoke arbitrary Tcl code.
*
*----------------------------------------------------------------------
*/
static void
TcpAccept(
TcpFdList *fds, /* Server socket that accepted newSocket. */
SOCKET newSocket, /* Newly accepted socket. */
address addr) /* Address of new socket. */
{
SocketInfo *newInfoPtr;
SocketInfo *infoPtr = fds->infoPtr;
int len = sizeof(addr);
char channelName[16 + TCL_INTEGER_SPACE];
char host[NI_MAXHOST], port[NI_MAXSERV];
ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
/*
* Win-NT has a misfeature that sockets are inherited in child processes
* by default. Turn off the inherit bit.
*/
SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);
|
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 |
* Select on read/write events and create the channel.
*/
newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
(LPARAM) newInfoPtr);
| | > > | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 |
* Select on read/write events and create the channel.
*/
newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
(LPARAM) newInfoPtr);
sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) newInfoPtr->sockets->fd);
newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_Close(NULL, newInfoPtr->channel);
return;
}
if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
== TCL_ERROR) {
Tcl_Close(NULL, newInfoPtr->channel);
return;
}
/*
* Invoke the accept callback function.
*/
if (infoPtr->acceptProc != NULL) {
getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel,
host, atoi(port));
}
}
/*
*----------------------------------------------------------------------
*
* TcpInputProc --
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 |
* read. We have to simulate blocking behavior here since we are always
* using non-blocking sockets.
*/
while (1) {
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) UNSELECT, (LPARAM) infoPtr);
bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0);
infoPtr->readyEvents &= ~(FD_READ);
/*
* Check for end-of-file condition or successful read.
*/
| > | 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 |
* read. We have to simulate blocking behavior here since we are always
* using non-blocking sockets.
*/
while (1) {
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) UNSELECT, (LPARAM) infoPtr);
/* single fd operation: this proc is only called for a connected socket. */
bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0);
infoPtr->readyEvents &= ~(FD_READ);
/*
* Check for end-of-file condition or successful read.
*/
|
| ︙ | ︙ | |||
1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 |
return -1;
}
while (1) {
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) UNSELECT, (LPARAM) infoPtr);
bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0);
if (bytesWritten != SOCKET_ERROR) {
/*
* Since Windows won't generate a new write event until we hit an
* overflow condition, we need to force the event loop to poll
* until the condition changes.
*/
| > | 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 |
return -1;
}
while (1) {
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) UNSELECT, (LPARAM) infoPtr);
/* single fd operation: this proc is only called for a connected socket. */
bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0);
if (bytesWritten != SOCKET_ERROR) {
/*
* Since Windows won't generate a new write event until we hit an
* overflow condition, we need to force the event loop to poll
* until the condition changes.
*/
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
if (interp) {
| > | > > | | > | | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 |
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"winsock is not initialized", -1));
}
return TCL_ERROR;
}
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
#error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list"
sock = infoPtr->sockets->fd;
if (!strcasecmp(optionName, "-keepalive")) {
BOOL val = FALSE;
int boolVar, rtn;
if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
return TCL_ERROR;
}
if (boolVar) {
val = TRUE;
}
rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE,
(const char *) &val, sizeof(BOOL));
if (rtn != 0) {
TclWinConvertError(WSAGetLastError());
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set socket option: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
} else if (!strcasecmp(optionName, "-nagle")) {
BOOL val = FALSE;
int boolVar, rtn;
if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) {
return TCL_ERROR;
}
if (!boolVar) {
val = TRUE;
}
rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY,
(const char *) &val, sizeof(BOOL));
if (rtn != 0) {
TclWinConvertError(WSAGetLastError());
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't set socket option: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName, "keepalive nagle");
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 |
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
if (interp) {
| > | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 |
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
*/
if (!SocketsEnabled()) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"winsock is not initialized", -1));
}
return TCL_ERROR;
}
sock = infoPtr->sockets->fd;
if (optionName != NULL) {
len = strlen(optionName);
|
| ︙ | ︙ | |||
2090 2091 2092 2093 2094 2095 2096 |
* an fconfigure request on a server socket (such sockets have no
* peer). {Copied from unix/tclUnixChan.c}
*/
if (len) {
TclWinConvertError((DWORD) WSAGetLastError());
if (interp) {
| > | | | 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 |
* an fconfigure request on a server socket (such sockets have no
* peer). {Copied from unix/tclUnixChan.c}
*/
if (len) {
TclWinConvertError((DWORD) WSAGetLastError());
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get peername: %s",
Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
}
if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 |
Tcl_DStringEndSublist(dsPtr);
} else {
return TCL_OK;
}
} else {
if (interp) {
TclWinConvertError((DWORD) WSAGetLastError());
| | | | 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 |
Tcl_DStringEndSublist(dsPtr);
} else {
return TCL_OK;
}
} else {
if (interp) {
TclWinConvertError((DWORD) WSAGetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get sockname: %s", Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
}
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
if (len == 0 || !strncmp(optionName, "-keepalive", len)) {
|
| ︙ | ︙ | |||
2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 |
UINT message,
WPARAM wParam,
LPARAM lParam)
{
int event, error;
SOCKET socket;
SocketInfo *infoPtr;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
GetWindowLong(hwnd, GWL_USERDATA);
#endif
| > | 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 |
UINT message,
WPARAM wParam,
LPARAM lParam)
{
int event, error;
SOCKET socket;
SocketInfo *infoPtr;
TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
GetWindowLong(hwnd, GWL_USERDATA);
#endif
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 |
* Find the specified socket on the socket list and update its
* eventState flag.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
| > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | | > | 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 |
* Find the specified socket on the socket list and update its
* eventState flag.
*/
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
if (fds->fd == socket) {
/*
* 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.
*/
if (event & FD_CLOSE) {
infoPtr->acceptEventCount = 0;
infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
} else if (event & FD_ACCEPT) {
infoPtr->acceptEventCount++;
}
if (event & FD_CONNECT) {
/*
* The socket is now connected, clear the async connect
* flag.
*/
infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
/*
* Remember any error that occurred so we can report
* connection failures.
*/
if (error != ERROR_SUCCESS) {
TclWinConvertError((DWORD) error);
infoPtr->lastError = Tcl_GetErrno();
}
}
if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
if (error != ERROR_SUCCESS) {
TclWinConvertError((DWORD) error);
infoPtr->lastError = Tcl_GetErrno();
}
infoPtr->readyEvents |= FD_WRITE;
}
infoPtr->readyEvents |= event;
/*
* Wake up the Main Thread.
*/
SetEvent(tsdPtr->readyEvent);
Tcl_ThreadAlert(tsdPtr->threadId);
break;
}
}
}
SetEvent(tsdPtr->socketListLock);
break;
case SOCKET_SELECT:
infoPtr = (SocketInfo *) lParam;
for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) {
infoPtr = (SocketInfo *) lParam;
if (wParam == SELECT) {
WSAAsyncSelect(fds->fd, hwnd,
SOCKET_MESSAGE, infoPtr->selectEvents);
} else {
/*
* Clear the selection mask
*/
WSAAsyncSelect(fds->fd, hwnd, 0, 0);
}
}
break;
case SOCKET_TERMINATE:
DestroyWindow(hwnd);
break;
}
|
| ︙ | ︙ | |||
2570 2571 2572 2573 2574 2575 2576 |
Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds));
} else {
Tcl_DStringInit(&ds);
if (TclpHasSockets(NULL) == TCL_OK) {
/*
| | < | < | | < < | | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 |
Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds));
} else {
Tcl_DStringInit(&ds);
if (TclpHasSockets(NULL) == TCL_OK) {
/*
* The buffer size of 256 is recommended by the MSDN page that
* documents gethostname() as being always adequate.
*/
Tcl_DString inDs;
Tcl_DStringInit(&inDs);
Tcl_DStringSetLength(&inDs, 256);
if (gethostname(Tcl_DStringValue(&inDs),
Tcl_DStringLength(&inDs)) == 0) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1,
&ds);
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
|
| ︙ | ︙ | |||
2659 2660 2661 2662 2663 2664 2665 |
if (!SocketsEnabled()) {
return SOCKET_ERROR;
}
return setsockopt(s, level, optname, optval, optlen);
}
| < < < < < < < < < < < < < < < < < | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 |
if (!SocketsEnabled()) {
return SOCKET_ERROR;
}
return setsockopt(s, level, optname, optval, optlen);
}
char *
TclpInetNtoa(
struct in_addr addr)
{
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" #include <sys/stat.h> /* * This is the master lock used to serialize access to other serialization * data structures. */ static CRITICAL_SECTION masterLock; | > > > > > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" #include <float.h> #include <sys/stat.h> /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* * This is the master lock used to serialize access to other serialization * data structures. */ static CRITICAL_SECTION masterLock; |
| ︙ | ︙ | |||
118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
static DWORD tlsKey;
typedef struct allocMutex {
Tcl_Mutex tlock;
CRITICAL_SECTION wlock;
} allocMutex;
#endif /* USE_THREAD_ALLOC */
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
*
* This procedure creates a new thread.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
static DWORD tlsKey;
typedef struct allocMutex {
Tcl_Mutex tlock;
CRITICAL_SECTION wlock;
} allocMutex;
#endif /* USE_THREAD_ALLOC */
/*
* The per thread data passed from TclpThreadCreate
* to TclWinThreadStart.
*/
typedef struct WinThread {
LPTHREAD_START_ROUTINE lpStartAddress; /* Original startup routine */
LPVOID lpParameter; /* Original startup data */
unsigned int fpControl; /* Floating point control word from the
* main thread */
} WinThread;
/*
*----------------------------------------------------------------------
*
* TclWinThreadStart --
*
* This procedure is the entry point for all new threads created
* by Tcl on Windows.
*
* Results:
* Various, depending on the result of the wrapped thread start
* routine.
*
* Side effects:
* Arbitrary, since user code is executed.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
TclWinThreadStart(
LPVOID lpParameter) /* The WinThread structure pointer passed
* from TclpThreadCreate */
{
WinThread *winThreadPtr = (WinThread *) lpParameter;
unsigned int fpmask;
LPTHREAD_START_ROUTINE lpOrigStartAddress;
LPVOID lpOrigParameter;
if (!winThreadPtr) {
return TCL_ERROR;
}
fpmask = _MCW_EM | _MCW_RC | _MCW_PC;
#if defined(_MSC_VER) && _MSC_VER >= 1200
fpmask |= _MCW_DN;
#endif
_controlfp(winThreadPtr->fpControl, fpmask);
lpOrigStartAddress = winThreadPtr->lpStartAddress;
lpOrigParameter = winThreadPtr->lpParameter;
ckfree((char *)winThreadPtr);
return lpOrigStartAddress(lpOrigParameter);
}
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
*
* This procedure creates a new thread.
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
int stackSize, /* Size of stack for the new thread. */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
HANDLE tHandle;
EnterCriticalSection(&joinLock);
*idPtr = 0; /* must initialize as Tcl_Thread is a pointer and
* on WIN64 sizeof void* != sizeof unsigned
*/
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
| > > > > > > | > | < | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 |
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
int stackSize, /* Size of stack for the new thread. */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
WinThread *winThreadPtr; /* Per-thread startup info */
HANDLE tHandle;
winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread));
winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc;
winThreadPtr->lpParameter = clientData;
winThreadPtr->fpControl = _controlfp(0, 0);
EnterCriticalSection(&joinLock);
*idPtr = 0; /* must initialize as Tcl_Thread is a pointer and
* on WIN64 sizeof void* != sizeof unsigned
*/
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize,
(Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr,
0, (unsigned *)idPtr);
#else
tHandle = CreateThread(NULL, (DWORD) stackSize,
TclWinThreadStart, winThreadPtr, 0, (LPDWORD)idPtr);
#endif
if (tHandle == NULL) {
LeaveCriticalSection(&joinLock);
return TCL_ERROR;
} else {
if (flags & TCL_THREAD_JOINABLE) {
|
| ︙ | ︙ |
Changes to win/tclooConfig.sh.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" | | | | 11 12 13 14 15 16 17 18 19 | # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" TCLOO_VERSION=1.0 |